From edcc77dbd9f95301a8be1a2f2b0d774680b46a1a Mon Sep 17 00:00:00 2001 From: Nicolas Roche Date: Fri, 8 Sep 2017 15:12:17 +0000 Subject: [PATCH] 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-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-cbsyqu.adb | 168 - gcc/ada/a-cbsyqu.ads | 103 - gcc/ada/a-cdlili.adb | 2186 --- gcc/ada/a-cdlili.ads | 406 - gcc/ada/a-cgaaso.adb | 47 - gcc/ada/a-cgaaso.ads | 41 - gcc/ada/a-cgarso.adb | 50 - gcc/ada/a-cgcaso.adb | 121 - 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-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-chzla1.ads | 376 - gcc/ada/a-chzla9.ads | 388 - gcc/ada/a-cidlli.adb | 2290 ---- gcc/ada/a-cidlli.ads | 397 - 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-coboho.adb | 99 - gcc/ada/a-coboho.ads | 114 - gcc/ada/a-cobove.adb | 2805 ---- gcc/ada/a-cobove.ads | 506 - gcc/ada/a-cogeso.adb | 127 - gcc/ada/a-cogeso.ads | 40 - 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-comutr.adb | 2676 ---- gcc/ada/a-comutr.ads | 511 - gcc/ada/a-conhel.adb | 186 - gcc/ada/a-conhel.ads | 159 - 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-crbltr.ads | 80 - gcc/ada/a-crbtgk.adb | 690 - gcc/ada/a-crbtgk.ads | 192 - 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-diocst.adb | 88 - gcc/ada/a-diocst.ads | 54 - gcc/ada/a-direct.ads | 487 - gcc/ada/a-direio.ads | 193 - 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-excach.adb | 74 - 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-locale.adb | 64 - gcc/ada/a-ngcefu.adb | 710 - gcc/ada/a-ngcoar.adb | 1255 -- gcc/ada/a-ngcoty.adb | 681 - gcc/ada/a-ngcoty.ads | 157 - gcc/ada/a-ngelfu.adb | 997 -- gcc/ada/a-ngrear.adb | 777 -- gcc/ada/a-ngrear.ads | 142 - gcc/ada/a-nudira.adb | 96 - gcc/ada/a-nudira.ads | 75 - 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-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-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-shcain.adb | 41 - gcc/ada/a-shcain.ads | 37 - gcc/ada/a-siocst.adb | 86 - gcc/ada/a-siocst.ads | 54 - gcc/ada/a-slcain.adb | 72 - gcc/ada/a-slcain.ads | 36 - gcc/ada/a-ssicst.ads | 53 - gcc/ada/a-stboha.adb | 40 - gcc/ada/a-stmaco.ads | 915 -- gcc/ada/a-storio.adb | 60 - gcc/ada/a-strbou.adb | 106 - gcc/ada/a-strbou.ads | 914 -- gcc/ada/a-stream.adb | 70 - gcc/ada/a-strhas.adb | 38 - gcc/ada/a-strmap.adb | 322 - gcc/ada/a-strmap.ads | 411 - gcc/ada/a-strsea.adb | 645 - 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-stuten.adb | 209 - gcc/ada/a-stwibo.adb | 94 - gcc/ada/a-stwibo.ads | 921 -- gcc/ada/a-stwifi.adb | 688 - gcc/ada/a-stwiha.adb | 40 - gcc/ada/a-stwima.adb | 742 -- gcc/ada/a-stwima.ads | 240 - gcc/ada/a-stwise.adb | 614 - 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-stzhas.adb | 36 - gcc/ada/a-stzmap.adb | 747 -- gcc/ada/a-stzmap.ads | 242 - gcc/ada/a-stzsea.adb | 617 - 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-suenst.adb | 350 - gcc/ada/a-suewst.adb | 370 - gcc/ada/a-suezst.adb | 429 - 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-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-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-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-szuzti-shared.adb | 135 - gcc/ada/a-szuzti.adb | 162 - gcc/ada/a-szuzti.ads | 71 - gcc/ada/a-teioed.adb | 2860 ---- gcc/ada/a-teioed.ads | 194 - gcc/ada/a-textio.ads | 471 - gcc/ada/a-tiboio.adb | 179 - 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-tifiio.adb | 716 - 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-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-undesu.adb | 43 - gcc/ada/a-wichha.adb | 195 - gcc/ada/a-wichun.adb | 178 - gcc/ada/a-wichun.ads | 197 - 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-wtcstr.adb | 85 - gcc/ada/a-wtcstr.ads | 53 - gcc/ada/a-wtdeau.adb | 265 - gcc/ada/a-wtdeau.ads | 93 - 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-wtfiio.adb | 126 - gcc/ada/a-wtflau.adb | 235 - gcc/ada/a-wtflau.ads | 72 - gcc/ada/a-wtflio.adb | 127 - 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-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-wwboio.adb | 179 - gcc/ada/a-zchhan.adb | 187 - 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-ztcoio.adb | 159 - 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-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-ztexio.ads | 497 - gcc/ada/a-ztfiio.adb | 126 - gcc/ada/a-ztflau.adb | 235 - gcc/ada/a-ztflau.ads | 72 - gcc/ada/a-ztflio.adb | 126 - 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-ztmoau.adb | 305 - gcc/ada/a-ztmoau.ads | 88 - gcc/ada/a-ztmoio.adb | 141 - gcc/ada/a-zttest.adb | 46 - gcc/ada/a-zzboio.adb | 180 - gcc/ada/ada.ads | 20 - 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-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-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.ads | 1201 -- 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.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.ads | 262 - 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-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-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-sechas.adb | 486 - 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-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.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-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-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-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/{ => libgnarl}/a-intnam-dragonfly.ads | 0 gcc/ada/{ => libgnarl}/a-intnam-rtems.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-cbdlli.adb | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-cfdlli.ads | 0 gcc/ada/{ => libgnat}/a-cfhama.adb | 0 gcc/ada/{ => libgnat}/a-cfhama.ads | 0 gcc/ada/{ => libgnat}/a-cfhase.adb | 0 gcc/ada/{ => libgnat}/a-cfhase.ads | 0 gcc/ada/{ => libgnat}/a-cfinve.adb | 0 gcc/ada/{ => libgnat}/a-cfinve.ads | 0 gcc/ada/{ => libgnat}/a-cforma.adb | 0 gcc/ada/{ => libgnat}/a-cforma.ads | 0 gcc/ada/{ => libgnat}/a-cforse.adb | 0 gcc/ada/{ => libgnat}/a-cforse.ads | 0 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 | 0 gcc/ada/libgnat/a-cgcaso.adb | 121 + gcc/ada/{ => libgnat}/a-cgcaso.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-chlat1.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-chtgop.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-cihama.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-clrefi.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-cofove.ads | 0 gcc/ada/{ => libgnat}/a-cofuba.adb | 0 gcc/ada/{ => libgnat}/a-cofuba.ads | 0 gcc/ada/{ => libgnat}/a-cofuma.adb | 0 gcc/ada/{ => libgnat}/a-cofuma.ads | 0 gcc/ada/{ => libgnat}/a-cofuse.adb | 0 gcc/ada/{ => libgnat}/a-cofuse.ads | 0 gcc/ada/{ => libgnat}/a-cofuve.adb | 0 gcc/ada/{ => libgnat}/a-cofuve.ads | 0 gcc/ada/libgnat/a-cogeso.adb | 127 + gcc/ada/libgnat/a-cogeso.ads | 40 + gcc/ada/{ => libgnat}/a-cohama.adb | 0 gcc/ada/{ => libgnat}/a-cohama.ads | 0 gcc/ada/{ => libgnat}/a-cohase.adb | 0 gcc/ada/{ => libgnat}/a-cohase.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-comlin.ads | 0 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 | 0 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 | 0 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 | 0 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 | 0 gcc/ada/libgnat/a-diocst.adb | 88 + gcc/ada/libgnat/a-diocst.ads | 54 + gcc/ada/{ => libgnat}/a-direct.adb | 0 gcc/ada/libgnat/a-direct.ads | 487 + gcc/ada/{ => libgnat}/a-direio.adb | 0 gcc/ada/libgnat/a-direio.ads | 193 + gcc/ada/{ => libgnat}/a-dirval-mingw.adb | 0 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 | 0 gcc/ada/libgnat/a-excach.adb | 74 + gcc/ada/{ => libgnat}/a-except.adb | 0 gcc/ada/{ => libgnat}/a-except.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-fwteio.ads | 0 gcc/ada/{ => libgnat}/a-fzteio.ads | 0 gcc/ada/{ => libgnat}/a-inteio.ads | 0 gcc/ada/{ => libgnat}/a-ioexce.ads | 0 gcc/ada/{ => libgnat}/a-iteint.ads | 0 gcc/ada/{ => libgnat}/a-iwteio.ads | 0 gcc/ada/{ => libgnat}/a-izteio.ads | 0 gcc/ada/{ => libgnat}/a-lcteio.ads | 0 gcc/ada/{ => libgnat}/a-lfteio.ads | 0 gcc/ada/{ => libgnat}/a-lfwtio.ads | 0 gcc/ada/{ => libgnat}/a-lfztio.ads | 0 gcc/ada/{ => libgnat}/a-liteio.ads | 0 gcc/ada/{ => libgnat}/a-liwtio.ads | 0 gcc/ada/{ => libgnat}/a-liztio.ads | 0 gcc/ada/{ => libgnat}/a-llctio.ads | 0 gcc/ada/{ => libgnat}/a-llftio.ads | 0 gcc/ada/{ => libgnat}/a-llfwti.ads | 0 gcc/ada/{ => libgnat}/a-llfzti.ads | 0 gcc/ada/{ => libgnat}/a-llitio.ads | 0 gcc/ada/{ => libgnat}/a-lliwti.ads | 0 gcc/ada/{ => libgnat}/a-llizti.ads | 0 gcc/ada/libgnat/a-locale.adb | 64 + gcc/ada/{ => libgnat}/a-locale.ads | 0 gcc/ada/{ => libgnat}/a-ncelfu.ads | 0 gcc/ada/libgnat/a-ngcefu.adb | 710 + gcc/ada/{ => libgnat}/a-ngcefu.ads | 0 gcc/ada/libgnat/a-ngcoar.adb | 1255 ++ gcc/ada/{ => libgnat}/a-ngcoar.ads | 0 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 | 0 gcc/ada/libgnat/a-ngrear.adb | 777 ++ gcc/ada/libgnat/a-ngrear.ads | 142 + gcc/ada/{ => libgnat}/a-nlcefu.ads | 0 gcc/ada/{ => libgnat}/a-nlcoar.ads | 0 gcc/ada/{ => libgnat}/a-nlcoty.ads | 0 gcc/ada/{ => libgnat}/a-nlelfu.ads | 0 gcc/ada/{ => libgnat}/a-nllcar.ads | 0 gcc/ada/{ => libgnat}/a-nllcef.ads | 0 gcc/ada/{ => libgnat}/a-nllcty.ads | 0 gcc/ada/{ => libgnat}/a-nllefu.ads | 0 gcc/ada/{ => libgnat}/a-nllrar.ads | 0 gcc/ada/{ => libgnat}/a-nlrear.ads | 0 gcc/ada/{ => libgnat}/a-nscefu.ads | 0 gcc/ada/{ => libgnat}/a-nscoty.ads | 0 gcc/ada/{ => libgnat}/a-nselfu.ads | 0 gcc/ada/{ => libgnat}/a-nucoar.ads | 0 gcc/ada/{ => libgnat}/a-nucoty.ads | 0 gcc/ada/libgnat/a-nudira.adb | 96 + gcc/ada/libgnat/a-nudira.ads | 75 + gcc/ada/{ => libgnat}/a-nuelfu.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-nurear.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-sfwtio.ads | 0 gcc/ada/{ => libgnat}/a-sfztio.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-siwtio.ads | 0 gcc/ada/{ => libgnat}/a-siztio.ads | 0 gcc/ada/libgnat/a-slcain.adb | 72 + gcc/ada/libgnat/a-slcain.ads | 36 + gcc/ada/{ => libgnat}/a-ssicst.adb | 0 gcc/ada/libgnat/a-ssicst.ads | 53 + gcc/ada/{ => libgnat}/a-ssitio.ads | 0 gcc/ada/{ => libgnat}/a-ssiwti.ads | 0 gcc/ada/{ => libgnat}/a-ssizti.ads | 0 gcc/ada/libgnat/a-stboha.adb | 40 + gcc/ada/{ => libgnat}/a-stboha.ads | 0 gcc/ada/{ => libgnat}/a-stfiha.ads | 0 gcc/ada/libgnat/a-stmaco.ads | 915 ++ gcc/ada/libgnat/a-storio.adb | 60 + gcc/ada/{ => libgnat}/a-storio.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-strfix.adb | 0 gcc/ada/{ => libgnat}/a-strfix.ads | 0 gcc/ada/libgnat/a-strhas.adb | 38 + gcc/ada/{ => libgnat}/a-strhas.ads | 0 gcc/ada/{ => libgnat}/a-string.ads | 0 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 | 0 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 | 0 gcc/ada/libgnat/a-stuten.adb | 209 + gcc/ada/{ => libgnat}/a-stuten.ads | 0 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 | 0 gcc/ada/libgnat/a-stwiha.adb | 40 + gcc/ada/{ => libgnat}/a-stwiha.ads | 0 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 | 0 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 | 0 gcc/ada/libgnat/a-stzhas.adb | 36 + gcc/ada/{ => libgnat}/a-stzhas.ads | 0 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 | 0 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 | 0 gcc/ada/libgnat/a-suenst.adb | 350 + gcc/ada/{ => libgnat}/a-suenst.ads | 0 gcc/ada/libgnat/a-suewst.adb | 370 + gcc/ada/{ => libgnat}/a-suewst.ads | 0 gcc/ada/libgnat/a-suezst.adb | 429 + gcc/ada/{ => libgnat}/a-suezst.ads | 0 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 | 0 gcc/ada/{ => libgnat}/a-swfwha.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-szfzha.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-tags.ads | 0 gcc/ada/libgnat/a-teioed.adb | 2860 ++++ gcc/ada/libgnat/a-teioed.ads | 194 + gcc/ada/{ => libgnat}/a-textio.adb | 0 gcc/ada/libgnat/a-textio.ads | 471 + gcc/ada/{ => libgnat}/a-tgdico.ads | 0 gcc/ada/libgnat/a-tiboio.adb | 179 + gcc/ada/{ => libgnat}/a-tiboio.ads | 0 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 | 0 gcc/ada/libgnat/a-tifiio.adb | 716 + gcc/ada/{ => libgnat}/a-tifiio.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-tiunio.ads | 0 gcc/ada/{ => libgnat}/a-unccon.ads | 0 gcc/ada/{ => libgnat}/a-uncdea.ads | 0 gcc/ada/libgnat/a-undesu.adb | 43 + gcc/ada/{ => libgnat}/a-undesu.ads | 0 gcc/ada/libgnat/a-wichha.adb | 195 + gcc/ada/{ => libgnat}/a-wichha.ads | 0 gcc/ada/libgnat/a-wichun.adb | 178 + gcc/ada/libgnat/a-wichun.ads | 197 + gcc/ada/{ => libgnat}/a-widcha.ads | 0 gcc/ada/{ => libgnat}/a-witeio.adb | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-wtdeio.ads | 0 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 | 0 gcc/ada/libgnat/a-wtfiio.adb | 126 + gcc/ada/{ => libgnat}/a-wtfiio.ads | 0 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 | 0 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 | 0 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 | 0 gcc/ada/libgnat/a-wwboio.adb | 179 + gcc/ada/{ => libgnat}/a-wwboio.ads | 0 gcc/ada/{ => libgnat}/a-wwunio.ads | 0 gcc/ada/{ => libgnat}/a-zchara.ads | 0 gcc/ada/libgnat/a-zchhan.adb | 187 + gcc/ada/{ => libgnat}/a-zchhan.ads | 0 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 | 0 gcc/ada/libgnat/a-ztcoio.adb | 159 + gcc/ada/{ => libgnat}/a-ztcoio.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/a-ztexio.adb | 0 gcc/ada/libgnat/a-ztexio.ads | 497 + gcc/ada/libgnat/a-ztfiio.adb | 126 + gcc/ada/{ => libgnat}/a-ztfiio.ads | 0 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 | 0 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 | 0 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 | 0 gcc/ada/libgnat/a-zttest.adb | 46 + gcc/ada/{ => libgnat}/a-zttest.ads | 0 gcc/ada/libgnat/a-zzboio.adb | 180 + gcc/ada/{ => libgnat}/a-zzboio.ads | 0 gcc/ada/{ => libgnat}/a-zzunio.ads | 0 gcc/ada/libgnat/ada.ads | 22 + gcc/ada/{ => libgnat}/calendar.ads | 0 gcc/ada/{ => libgnat}/directio.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/g-catiio.ads | 0 gcc/ada/{ => libgnat}/g-cgi.adb | 0 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 | 0 gcc/ada/libgnat/g-comlin.ads | 1201 ++ gcc/ada/{ => libgnat}/g-comver.adb | 0 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 | 0 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 | 0 gcc/ada/libgnat/g-dirope.ads | 262 + gcc/ada/{ => libgnat}/g-dynhta.adb | 0 gcc/ada/{ => libgnat}/g-dynhta.ads | 0 gcc/ada/{ => libgnat}/g-dyntab.adb | 0 gcc/ada/{ => libgnat}/g-dyntab.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/g-forstr.ads | 0 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 | 0 gcc/ada/libgnat/g-sechas.adb | 486 + gcc/ada/{ => libgnat}/g-sechas.ads | 0 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 | 0 gcc/ada/{ => libgnat}/g-socket.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/g-table.ads | 0 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 | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/machcode.ads | 0 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 | 0 gcc/ada/libgnat/s-diinio.adb | 109 + gcc/ada/{ => libgnat}/s-diinio.ads | 0 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 | 0 gcc/ada/{ => libgnat}/s-dwalin.ads | 0 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 | 0 gcc/ada/{ => libgnat}/s-excmac-arm.ads | 0 gcc/ada/{ => libgnat}/s-excmac-gcc.adb | 0 gcc/ada/{ => libgnat}/s-excmac-gcc.ads | 0 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 | 0 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 | 0 gcc/ada/libgnat/s-fileio.ads | 255 + gcc/ada/libgnat/s-finmas.adb | 554 + gcc/ada/{ => libgnat}/s-finmas.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/s-objrea.adb | 0 gcc/ada/{ => libgnat}/s-objrea.ads | 0 gcc/ada/{ => libgnat}/s-os_lib.adb | 0 gcc/ada/{ => libgnat}/s-os_lib.ads | 0 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 | 0 gcc/ada/{ => libgnat}/s-parame-rtems.adb | 0 gcc/ada/libgnat/s-parame-vxworks.adb | 80 + gcc/ada/{ => libgnat}/s-parame-vxworks.ads | 0 gcc/ada/libgnat/s-parame.adb | 82 + gcc/ada/{ => libgnat}/s-parame.ads | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/s-regexp.ads | 0 gcc/ada/{ => libgnat}/s-regpat.adb | 0 gcc/ada/libgnat/s-regpat.ads | 649 + gcc/ada/{ => libgnat}/s-resfil.adb | 0 gcc/ada/{ => libgnat}/s-resfil.ads | 0 gcc/ada/libgnat/s-restri.adb | 59 + gcc/ada/libgnat/s-restri.ads | 77 + gcc/ada/{ => libgnat}/s-rident.ads | 0 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 | 0 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 | 0 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 | 0 gcc/ada/{ => libgnat}/s-ststop.ads | 0 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 | 0 gcc/ada/{ => libgnat}/s-trasym.adb | 0 gcc/ada/libgnat/s-trasym.ads | 111 + gcc/ada/{ => libgnat}/s-tsmona-linux.adb | 0 gcc/ada/{ => libgnat}/s-tsmona-mingw.adb | 0 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 | 0 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 | 0 .../{ => libgnat}/system-dragonfly-x86_64.ads | 0 gcc/ada/{ => libgnat}/system-freebsd.ads | 0 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 | 0 gcc/ada/libgnat/system-linux-hppa.ads | 147 + gcc/ada/libgnat/system-linux-ia64.ads | 156 + gcc/ada/{ => libgnat}/system-linux-m68k.ads | 0 gcc/ada/{ => libgnat}/system-linux-mips.ads | 0 gcc/ada/{ => libgnat}/system-linux-ppc.ads | 0 gcc/ada/{ => libgnat}/system-linux-s390.ads | 0 gcc/ada/libgnat/system-linux-sh4.ads | 155 + gcc/ada/libgnat/system-linux-sparc.ads | 147 + gcc/ada/{ => libgnat}/system-linux-x86.ads | 0 gcc/ada/libgnat/system-mingw.ads | 200 + gcc/ada/{ => libgnat}/system-rtems.ads | 0 gcc/ada/libgnat/system-solaris-sparc.ads | 148 + gcc/ada/libgnat/system-solaris-x86.ads | 148 + .../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 + .../libgnat/system-vxworks-e500-kernel.ads | 167 + .../libgnat/system-vxworks-e500-rtp-smp.ads | 173 + gcc/ada/libgnat/system-vxworks-e500-rtp.ads | 171 + .../libgnat/system-vxworks-e500-vthread.ads | 164 + gcc/ada/libgnat/system-vxworks-ppc-kernel.ads | 166 + .../libgnat/system-vxworks-ppc-ravenscar.ads | 187 + .../libgnat/system-vxworks-ppc-rtp-smp.ads | 172 + gcc/ada/libgnat/system-vxworks-ppc-rtp.ads | 171 + .../libgnat/system-vxworks-ppc-vthread.ads | 164 + gcc/ada/libgnat/system-vxworks-ppc.ads | 169 + .../libgnat/system-vxworks-ppc64-kernel.ads | 168 + gcc/ada/libgnat/system-vxworks-x86-kernel.ads | 170 + .../libgnat/system-vxworks-x86-rtp-smp.ads | 171 + gcc/ada/libgnat/system-vxworks-x86-rtp.ads | 170 + .../libgnat/system-vxworks-x86-vthread.ads | 165 + gcc/ada/libgnat/system-vxworks-x86.ads | 166 + .../libgnat/system-vxworks7-arm-rtp-smp.ads | 167 + gcc/ada/libgnat/system-vxworks7-arm.ads | 162 + .../libgnat/system-vxworks7-e500-rtp-smp.ads | 172 + .../libgnat/system-vxworks7-ppc-rtp-smp.ads | 171 + .../libgnat/system-vxworks7-ppc64-rtp-smp.ads | 171 + .../libgnat/system-vxworks7-x86-kernel.ads | 167 + .../libgnat/system-vxworks7-x86-rtp-smp.ads | 170 + .../libgnat/system-vxworks7-x86_64-kernel.ads | 167 + .../system-vxworks7-x86_64-rtp-smp.ads | 170 + gcc/ada/{ => libgnat}/system.ads | 0 gcc/ada/{ => libgnat}/text_io.ads | 0 gcc/ada/{ => libgnat}/unchconv.ads | 0 gcc/ada/{ => libgnat}/unchdeal.ads | 0 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-diinio.adb | 109 - 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-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-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.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.ads | 255 - gcc/ada/s-finmas.adb | 554 - 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.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-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-vxworks.adb | 80 - gcc/ada/s-parame.adb | 82 - 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-rannum.adb | 693 - gcc/ada/s-rannum.ads | 162 - gcc/ada/s-ransee.adb | 55 - gcc/ada/s-ransee.ads | 49 - gcc/ada/s-regpat.ads | 649 - gcc/ada/s-restri.adb | 59 - gcc/ada/s-restri.ads | 77 - 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-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.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-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.ads | 98 - 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/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-hpux-ia64.ads | 148 - gcc/ada/system-hpux.ads | 223 - gcc/ada/system-linux-alpha.ads | 148 - gcc/ada/system-linux-hppa.ads | 147 - gcc/ada/system-linux-ia64.ads | 156 - gcc/ada/system-linux-sh4.ads | 155 - gcc/ada/system-linux-sparc.ads | 147 - gcc/ada/system-mingw.ads | 200 - 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 - 2307 files changed, 284869 insertions(+), 279329 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-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-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-cgaaso.adb delete mode 100644 gcc/ada/a-cgaaso.ads delete mode 100644 gcc/ada/a-cgarso.adb delete mode 100644 gcc/ada/a-cgcaso.adb 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-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-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-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-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-cogeso.adb delete mode 100644 gcc/ada/a-cogeso.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-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-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-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.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-diocst.adb delete mode 100644 gcc/ada/a-diocst.ads delete mode 100644 gcc/ada/a-direct.ads delete mode 100644 gcc/ada/a-direio.ads 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-excach.adb 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-locale.adb delete mode 100644 gcc/ada/a-ngcefu.adb delete mode 100644 gcc/ada/a-ngcoar.adb 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-ngrear.adb delete mode 100644 gcc/ada/a-ngrear.ads delete mode 100644 gcc/ada/a-nudira.adb delete mode 100644 gcc/ada/a-nudira.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-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-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-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-slcain.adb delete mode 100644 gcc/ada/a-slcain.ads delete mode 100644 gcc/ada/a-ssicst.ads delete mode 100644 gcc/ada/a-stboha.adb delete mode 100644 gcc/ada/a-stmaco.ads delete mode 100644 gcc/ada/a-storio.adb 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-strhas.adb 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-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-stuten.adb 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-stwiha.adb 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-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-stzhas.adb 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-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-suenst.adb delete mode 100644 gcc/ada/a-suewst.adb delete mode 100644 gcc/ada/a-suezst.adb 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-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-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-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-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-teioed.adb delete mode 100644 gcc/ada/a-teioed.ads delete mode 100644 gcc/ada/a-textio.ads delete mode 100644 gcc/ada/a-tiboio.adb 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-tifiio.adb 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-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-undesu.adb delete mode 100644 gcc/ada/a-wichha.adb delete mode 100644 gcc/ada/a-wichun.adb delete mode 100644 gcc/ada/a-wichun.ads 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-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-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-wtfiio.adb 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-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-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-wwboio.adb delete mode 100644 gcc/ada/a-zchhan.adb 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-ztcoio.adb 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-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-ztexio.ads delete mode 100644 gcc/ada/a-ztfiio.adb 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-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-ztmoau.adb delete mode 100644 gcc/ada/a-ztmoau.ads delete mode 100644 gcc/ada/a-ztmoio.adb delete mode 100644 gcc/ada/a-zttest.adb delete mode 100644 gcc/ada/a-zzboio.adb delete mode 100644 gcc/ada/ada.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-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-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.ads 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.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.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-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-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-sechas.adb 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-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.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-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-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-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 rename gcc/ada/{ => libgnarl}/a-intnam-dragonfly.ads (100%) rename gcc/ada/{ => libgnarl}/a-intnam-rtems.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-catizo.ads (100%) rename gcc/ada/{ => libgnat}/a-cbdlli.adb (100%) 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 rename gcc/ada/{ => libgnat}/a-cbprqu.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-cfdlli.adb (100%) rename gcc/ada/{ => libgnat}/a-cfdlli.ads (100%) rename gcc/ada/{ => libgnat}/a-cfhama.adb (100%) rename gcc/ada/{ => libgnat}/a-cfhama.ads (100%) rename gcc/ada/{ => libgnat}/a-cfhase.adb (100%) rename gcc/ada/{ => libgnat}/a-cfhase.ads (100%) rename gcc/ada/{ => libgnat}/a-cfinve.adb (100%) rename gcc/ada/{ => libgnat}/a-cfinve.ads (100%) rename gcc/ada/{ => libgnat}/a-cforma.adb (100%) rename gcc/ada/{ => libgnat}/a-cforma.ads (100%) rename gcc/ada/{ => libgnat}/a-cforse.adb (100%) rename gcc/ada/{ => libgnat}/a-cforse.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-cgarso.ads (100%) create mode 100644 gcc/ada/libgnat/a-cgcaso.adb rename gcc/ada/{ => libgnat}/a-cgcaso.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-charac.ads (100%) rename gcc/ada/{ => libgnat}/a-chlat1.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-chtgop.adb (100%) rename gcc/ada/{ => libgnat}/a-chtgop.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-cihama.adb (100%) rename gcc/ada/{ => libgnat}/a-cihama.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-clrefi.adb (100%) rename gcc/ada/{ => libgnat}/a-clrefi.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-cofove.adb (100%) rename gcc/ada/{ => libgnat}/a-cofove.ads (100%) rename gcc/ada/{ => libgnat}/a-cofuba.adb (100%) rename gcc/ada/{ => libgnat}/a-cofuba.ads (100%) rename gcc/ada/{ => libgnat}/a-cofuma.adb (100%) rename gcc/ada/{ => libgnat}/a-cofuma.ads (100%) rename gcc/ada/{ => libgnat}/a-cofuse.adb (100%) rename gcc/ada/{ => libgnat}/a-cofuse.ads (100%) rename gcc/ada/{ => libgnat}/a-cofuve.adb (100%) rename gcc/ada/{ => libgnat}/a-cofuve.ads (100%) create mode 100644 gcc/ada/libgnat/a-cogeso.adb create mode 100644 gcc/ada/libgnat/a-cogeso.ads rename gcc/ada/{ => libgnat}/a-cohama.adb (100%) rename gcc/ada/{ => libgnat}/a-cohama.ads (100%) rename gcc/ada/{ => libgnat}/a-cohase.adb (100%) rename gcc/ada/{ => libgnat}/a-cohase.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-comlin.adb (100%) rename gcc/ada/{ => libgnat}/a-comlin.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-contai.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-coteio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-crbtgo.adb (100%) 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 rename gcc/ada/{ => libgnat}/a-dhfina.ads (100%) create mode 100644 gcc/ada/libgnat/a-diocst.adb create mode 100644 gcc/ada/libgnat/a-diocst.ads rename gcc/ada/{ => libgnat}/a-direct.adb (100%) create mode 100644 gcc/ada/libgnat/a-direct.ads rename gcc/ada/{ => libgnat}/a-direio.adb (100%) create mode 100644 gcc/ada/libgnat/a-direio.ads rename gcc/ada/{ => libgnat}/a-dirval-mingw.adb (100%) 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 rename gcc/ada/{ => libgnat}/a-envvar.ads (100%) create mode 100644 gcc/ada/libgnat/a-excach.adb rename gcc/ada/{ => libgnat}/a-except.adb (100%) rename gcc/ada/{ => libgnat}/a-except.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-flteio.ads (100%) rename gcc/ada/{ => libgnat}/a-fwteio.ads (100%) rename gcc/ada/{ => libgnat}/a-fzteio.ads (100%) rename gcc/ada/{ => libgnat}/a-inteio.ads (100%) rename gcc/ada/{ => libgnat}/a-ioexce.ads (100%) rename gcc/ada/{ => libgnat}/a-iteint.ads (100%) rename gcc/ada/{ => libgnat}/a-iwteio.ads (100%) rename gcc/ada/{ => libgnat}/a-izteio.ads (100%) rename gcc/ada/{ => libgnat}/a-lcteio.ads (100%) rename gcc/ada/{ => libgnat}/a-lfteio.ads (100%) rename gcc/ada/{ => libgnat}/a-lfwtio.ads (100%) rename gcc/ada/{ => libgnat}/a-lfztio.ads (100%) rename gcc/ada/{ => libgnat}/a-liteio.ads (100%) rename gcc/ada/{ => libgnat}/a-liwtio.ads (100%) rename gcc/ada/{ => libgnat}/a-liztio.ads (100%) rename gcc/ada/{ => libgnat}/a-llctio.ads (100%) rename gcc/ada/{ => libgnat}/a-llftio.ads (100%) rename gcc/ada/{ => libgnat}/a-llfwti.ads (100%) rename gcc/ada/{ => libgnat}/a-llfzti.ads (100%) rename gcc/ada/{ => libgnat}/a-llitio.ads (100%) rename gcc/ada/{ => libgnat}/a-lliwti.ads (100%) rename gcc/ada/{ => libgnat}/a-llizti.ads (100%) create mode 100644 gcc/ada/libgnat/a-locale.adb rename gcc/ada/{ => libgnat}/a-locale.ads (100%) rename gcc/ada/{ => libgnat}/a-ncelfu.ads (100%) create mode 100644 gcc/ada/libgnat/a-ngcefu.adb rename gcc/ada/{ => libgnat}/a-ngcefu.ads (100%) create mode 100644 gcc/ada/libgnat/a-ngcoar.adb rename gcc/ada/{ => libgnat}/a-ngcoar.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ngelfu.ads (100%) create mode 100644 gcc/ada/libgnat/a-ngrear.adb create mode 100644 gcc/ada/libgnat/a-ngrear.ads rename gcc/ada/{ => libgnat}/a-nlcefu.ads (100%) rename gcc/ada/{ => libgnat}/a-nlcoar.ads (100%) rename gcc/ada/{ => libgnat}/a-nlcoty.ads (100%) rename gcc/ada/{ => libgnat}/a-nlelfu.ads (100%) rename gcc/ada/{ => libgnat}/a-nllcar.ads (100%) rename gcc/ada/{ => libgnat}/a-nllcef.ads (100%) rename gcc/ada/{ => libgnat}/a-nllcty.ads (100%) rename gcc/ada/{ => libgnat}/a-nllefu.ads (100%) rename gcc/ada/{ => libgnat}/a-nllrar.ads (100%) rename gcc/ada/{ => libgnat}/a-nlrear.ads (100%) rename gcc/ada/{ => libgnat}/a-nscefu.ads (100%) rename gcc/ada/{ => libgnat}/a-nscoty.ads (100%) rename gcc/ada/{ => libgnat}/a-nselfu.ads (100%) rename gcc/ada/{ => libgnat}/a-nucoar.ads (100%) rename gcc/ada/{ => libgnat}/a-nucoty.ads (100%) create mode 100644 gcc/ada/libgnat/a-nudira.adb create mode 100644 gcc/ada/libgnat/a-nudira.ads rename gcc/ada/{ => libgnat}/a-nuelfu.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-numeri.ads (100%) rename gcc/ada/{ => libgnat}/a-nurear.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-scteio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-sfteio.ads (100%) rename gcc/ada/{ => libgnat}/a-sfwtio.ads (100%) rename gcc/ada/{ => libgnat}/a-sfztio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-siteio.ads (100%) rename gcc/ada/{ => libgnat}/a-siwtio.ads (100%) rename gcc/ada/{ => libgnat}/a-siztio.ads (100%) create mode 100644 gcc/ada/libgnat/a-slcain.adb create mode 100644 gcc/ada/libgnat/a-slcain.ads rename gcc/ada/{ => libgnat}/a-ssicst.adb (100%) create mode 100644 gcc/ada/libgnat/a-ssicst.ads rename gcc/ada/{ => libgnat}/a-ssitio.ads (100%) rename gcc/ada/{ => libgnat}/a-ssiwti.ads (100%) rename gcc/ada/{ => libgnat}/a-ssizti.ads (100%) create mode 100644 gcc/ada/libgnat/a-stboha.adb rename gcc/ada/{ => libgnat}/a-stboha.ads (100%) rename gcc/ada/{ => libgnat}/a-stfiha.ads (100%) create mode 100644 gcc/ada/libgnat/a-stmaco.ads create mode 100644 gcc/ada/libgnat/a-storio.adb rename gcc/ada/{ => libgnat}/a-storio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-stream.ads (100%) rename gcc/ada/{ => libgnat}/a-strfix.adb (100%) rename gcc/ada/{ => libgnat}/a-strfix.ads (100%) create mode 100644 gcc/ada/libgnat/a-strhas.adb rename gcc/ada/{ => libgnat}/a-strhas.ads (100%) rename gcc/ada/{ => libgnat}/a-string.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-strsea.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-stunha.ads (100%) create mode 100644 gcc/ada/libgnat/a-stuten.adb rename gcc/ada/{ => libgnat}/a-stuten.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-stwifi.ads (100%) create mode 100644 gcc/ada/libgnat/a-stwiha.adb rename gcc/ada/{ => libgnat}/a-stwiha.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-stwise.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-stzfix.ads (100%) create mode 100644 gcc/ada/libgnat/a-stzhas.adb rename gcc/ada/{ => libgnat}/a-stzhas.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-stzsea.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-suenco.ads (100%) create mode 100644 gcc/ada/libgnat/a-suenst.adb rename gcc/ada/{ => libgnat}/a-suenst.ads (100%) create mode 100644 gcc/ada/libgnat/a-suewst.adb rename gcc/ada/{ => libgnat}/a-suewst.ads (100%) create mode 100644 gcc/ada/libgnat/a-suezst.adb rename gcc/ada/{ => libgnat}/a-suezst.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-swbwha.ads (100%) rename gcc/ada/{ => libgnat}/a-swfwha.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-swuwha.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-szbzha.ads (100%) rename gcc/ada/{ => libgnat}/a-szfzha.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-szuzha.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-tags.adb (100%) rename gcc/ada/{ => libgnat}/a-tags.ads (100%) create mode 100644 gcc/ada/libgnat/a-teioed.adb create mode 100644 gcc/ada/libgnat/a-teioed.ads rename gcc/ada/{ => libgnat}/a-textio.adb (100%) create mode 100644 gcc/ada/libgnat/a-textio.ads rename gcc/ada/{ => libgnat}/a-tgdico.ads (100%) create mode 100644 gcc/ada/libgnat/a-tiboio.adb rename gcc/ada/{ => libgnat}/a-tiboio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-tienio.ads (100%) create mode 100644 gcc/ada/libgnat/a-tifiio.adb rename gcc/ada/{ => libgnat}/a-tifiio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-tigeli.adb (100%) 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 rename gcc/ada/{ => libgnat}/a-titest.ads (100%) rename gcc/ada/{ => libgnat}/a-tiunio.ads (100%) rename gcc/ada/{ => libgnat}/a-unccon.ads (100%) rename gcc/ada/{ => libgnat}/a-uncdea.ads (100%) create mode 100644 gcc/ada/libgnat/a-undesu.adb rename gcc/ada/{ => libgnat}/a-undesu.ads (100%) create mode 100644 gcc/ada/libgnat/a-wichha.adb rename gcc/ada/{ => libgnat}/a-wichha.ads (100%) create mode 100644 gcc/ada/libgnat/a-wichun.adb create mode 100644 gcc/ada/libgnat/a-wichun.ads rename gcc/ada/{ => libgnat}/a-widcha.ads (100%) rename gcc/ada/{ => libgnat}/a-witeio.adb (100%) 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 rename gcc/ada/{ => libgnat}/a-wtcoio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-wtdeio.adb (100%) rename gcc/ada/{ => libgnat}/a-wtdeio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-wtenio.ads (100%) create mode 100644 gcc/ada/libgnat/a-wtfiio.adb rename gcc/ada/{ => libgnat}/a-wtfiio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-wtflio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-wtinio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-wttest.ads (100%) create mode 100644 gcc/ada/libgnat/a-wwboio.adb rename gcc/ada/{ => libgnat}/a-wwboio.ads (100%) rename gcc/ada/{ => libgnat}/a-wwunio.ads (100%) rename gcc/ada/{ => libgnat}/a-zchara.ads (100%) create mode 100644 gcc/ada/libgnat/a-zchhan.adb rename gcc/ada/{ => libgnat}/a-zchhan.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ztcoau.ads (100%) create mode 100644 gcc/ada/libgnat/a-ztcoio.adb rename gcc/ada/{ => libgnat}/a-ztcoio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ztdeio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ztenio.ads (100%) rename gcc/ada/{ => libgnat}/a-ztexio.adb (100%) create mode 100644 gcc/ada/libgnat/a-ztexio.ads create mode 100644 gcc/ada/libgnat/a-ztfiio.adb rename gcc/ada/{ => libgnat}/a-ztfiio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ztflio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ztinio.ads (100%) 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 rename gcc/ada/{ => libgnat}/a-ztmoio.ads (100%) create mode 100644 gcc/ada/libgnat/a-zttest.adb rename gcc/ada/{ => libgnat}/a-zttest.ads (100%) create mode 100644 gcc/ada/libgnat/a-zzboio.adb rename gcc/ada/{ => libgnat}/a-zzboio.ads (100%) rename gcc/ada/{ => libgnat}/a-zzunio.ads (100%) create mode 100644 gcc/ada/libgnat/ada.ads rename gcc/ada/{ => libgnat}/calendar.ads (100%) rename gcc/ada/{ => libgnat}/directio.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-altive.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-catiio.adb (100%) rename gcc/ada/{ => libgnat}/g-catiio.ads (100%) rename gcc/ada/{ => libgnat}/g-cgi.adb (100%) 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 rename gcc/ada/{ => libgnat}/g-comlin.adb (100%) create mode 100644 gcc/ada/libgnat/g-comlin.ads rename gcc/ada/{ => libgnat}/g-comver.adb (100%) 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 rename gcc/ada/{ => libgnat}/g-debpoo.adb (100%) 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 rename gcc/ada/{ => libgnat}/g-dirope.adb (100%) create mode 100644 gcc/ada/libgnat/g-dirope.ads rename gcc/ada/{ => libgnat}/g-dynhta.adb (100%) rename gcc/ada/{ => libgnat}/g-dynhta.ads (100%) rename gcc/ada/{ => libgnat}/g-dyntab.adb (100%) rename gcc/ada/{ => libgnat}/g-dyntab.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-except.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-forstr.adb (100%) rename gcc/ada/{ => libgnat}/g-forstr.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-rewdat.ads (100%) create mode 100644 gcc/ada/libgnat/g-sechas.adb rename gcc/ada/{ => libgnat}/g-sechas.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-socket.adb (100%) rename gcc/ada/{ => libgnat}/g-socket.ads (100%) 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 rename gcc/ada/{ => libgnat}/g-spipat.adb (100%) 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 rename gcc/ada/{ => libgnat}/g-table.adb (100%) rename gcc/ada/{ => libgnat}/g-table.ads (100%) 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 rename gcc/ada/{ => libgnat}/i-c.ads (100%) 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 rename gcc/ada/{ => libgnat}/i-fortra.ads (100%) 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 rename gcc/ada/{ => libgnat}/ioexcept.ads (100%) rename gcc/ada/{ => libgnat}/machcode.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-diflio.ads (100%) create mode 100644 gcc/ada/libgnat/s-diinio.adb rename gcc/ada/{ => libgnat}/s-diinio.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-dwalin.adb (100%) rename gcc/ada/{ => libgnat}/s-dwalin.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-excmac-arm.adb (100%) rename gcc/ada/{ => libgnat}/s-excmac-arm.ads (100%) rename gcc/ada/{ => libgnat}/s-excmac-gcc.adb (100%) rename gcc/ada/{ => libgnat}/s-excmac-gcc.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-fatgen.adb (100%) 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 rename gcc/ada/{ => libgnat}/s-fileio.adb (100%) create mode 100644 gcc/ada/libgnat/s-fileio.ads create mode 100644 gcc/ada/libgnat/s-finmas.adb rename gcc/ada/{ => libgnat}/s-finmas.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-htable.adb (100%) 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 rename gcc/ada/{ => libgnat}/s-multip.ads (100%) rename gcc/ada/{ => libgnat}/s-objrea.adb (100%) rename gcc/ada/{ => libgnat}/s-objrea.ads (100%) rename gcc/ada/{ => libgnat}/s-os_lib.adb (100%) rename gcc/ada/{ => libgnat}/s-os_lib.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-parame-hpux.ads (100%) rename gcc/ada/{ => libgnat}/s-parame-rtems.adb (100%) create mode 100644 gcc/ada/libgnat/s-parame-vxworks.adb rename gcc/ada/{ => libgnat}/s-parame-vxworks.ads (100%) create mode 100644 gcc/ada/libgnat/s-parame.adb rename gcc/ada/{ => libgnat}/s-parame.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-purexc.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-regexp.adb (100%) rename gcc/ada/{ => libgnat}/s-regexp.ads (100%) rename gcc/ada/{ => libgnat}/s-regpat.adb (100%) create mode 100644 gcc/ada/libgnat/s-regpat.ads rename gcc/ada/{ => libgnat}/s-resfil.adb (100%) rename gcc/ada/{ => libgnat}/s-resfil.ads (100%) create mode 100644 gcc/ada/libgnat/s-restri.adb create mode 100644 gcc/ada/libgnat/s-restri.ads rename gcc/ada/{ => libgnat}/s-rident.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-stchop-rtems.adb (100%) 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 rename gcc/ada/{ => libgnat}/s-stposu.adb (100%) 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 rename gcc/ada/{ => libgnat}/s-ststop.adb (100%) rename gcc/ada/{ => libgnat}/s-ststop.ads (100%) 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 rename gcc/ada/{ => libgnat}/s-trasym-dwarf.adb (100%) rename gcc/ada/{ => libgnat}/s-trasym.adb (100%) create mode 100644 gcc/ada/libgnat/s-trasym.ads rename gcc/ada/{ => libgnat}/s-tsmona-linux.adb (100%) rename gcc/ada/{ => libgnat}/s-tsmona-mingw.adb (100%) 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 rename gcc/ada/{ => libgnat}/sequenio.ads (100%) 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 rename gcc/ada/{ => libgnat}/system-djgpp.ads (100%) rename gcc/ada/{ => libgnat}/system-dragonfly-x86_64.ads (100%) rename gcc/ada/{ => libgnat}/system-freebsd.ads (100%) 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 rename gcc/ada/{ => libgnat}/system-linux-arm.ads (100%) create mode 100644 gcc/ada/libgnat/system-linux-hppa.ads create mode 100644 gcc/ada/libgnat/system-linux-ia64.ads rename gcc/ada/{ => libgnat}/system-linux-m68k.ads (100%) rename gcc/ada/{ => libgnat}/system-linux-mips.ads (100%) rename gcc/ada/{ => libgnat}/system-linux-ppc.ads (100%) rename gcc/ada/{ => libgnat}/system-linux-s390.ads (100%) create mode 100644 gcc/ada/libgnat/system-linux-sh4.ads create mode 100644 gcc/ada/libgnat/system-linux-sparc.ads rename gcc/ada/{ => libgnat}/system-linux-x86.ads (100%) create mode 100644 gcc/ada/libgnat/system-mingw.ads rename gcc/ada/{ => libgnat}/system-rtems.ads (100%) 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 rename gcc/ada/{ => libgnat}/system.ads (100%) rename gcc/ada/{ => libgnat}/text_io.ads (100%) rename gcc/ada/{ => libgnat}/unchconv.ads (100%) rename gcc/ada/{ => libgnat}/unchdeal.ads (100%) 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-diinio.adb 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-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-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.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.ads delete mode 100644 gcc/ada/s-finmas.adb 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.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-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-vxworks.adb delete mode 100644 gcc/ada/s-parame.adb 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-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-regpat.ads delete mode 100644 gcc/ada/s-restri.adb delete mode 100644 gcc/ada/s-restri.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-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.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-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.ads 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/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-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-hppa.ads delete mode 100644 gcc/ada/system-linux-ia64.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-mingw.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 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 113cbca5df3..7b3ab766f00 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 bfdcd157245..00000000000 --- 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 d0ce6f08316..00000000000 --- 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 363b77e349a..00000000000 --- 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 0527a90c442..00000000000 --- 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 1166b4349a3..00000000000 --- 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 64ebc623b7f..00000000000 --- 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 f24b971b226..00000000000 --- 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 0fbf4a178aa..00000000000 --- 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 efa4478dd59..00000000000 --- 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 1a0b129d33e..00000000000 --- 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 b0fba5dd145..00000000000 --- 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 39e9c33c13f..00000000000 --- 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 6da6f1d40b9..00000000000 --- 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 8cfd6a403dc..00000000000 --- 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 3c3c02f709c..00000000000 --- 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-cbdlli.ads b/gcc/ada/a-cbdlli.ads deleted file mode 100644 index 8489153917a..00000000000 --- 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 02c190198e6..00000000000 --- 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 0bab22e13b6..00000000000 --- 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 59b0bdb99de..00000000000 --- 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 1023fc50464..00000000000 --- 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 3fe986d1c9a..00000000000 --- 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 66001976031..00000000000 --- 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 611e8953e16..00000000000 --- 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 7aa6e6c4ef6..00000000000 --- 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 85d65666cdc..00000000000 --- 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 f342ab81b9a..00000000000 --- 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 8256d862115..00000000000 --- 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-cbsyqu.adb b/gcc/ada/a-cbsyqu.adb deleted file mode 100644 index 0f29d9f8115..00000000000 --- 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 e22e0823de3..00000000000 --- 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 011c3950730..00000000000 --- 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 a1bc17cb020..00000000000 --- 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-cgaaso.adb b/gcc/ada/a-cgaaso.adb deleted file mode 100644 index 12763f12a67..00000000000 --- 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 f44c2207a81..00000000000 --- 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 0947747376c..00000000000 --- 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-cgcaso.adb b/gcc/ada/a-cgcaso.adb deleted file mode 100644 index 646137719b2..00000000000 --- 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-chacon.adb b/gcc/ada/a-chacon.adb deleted file mode 100644 index 36029fd3072..00000000000 --- 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 77525a4f725..00000000000 --- 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 f95a7bb0eaf..00000000000 --- 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 c34e5e2e450..00000000000 --- 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-chlat9.ads b/gcc/ada/a-chlat9.ads deleted file mode 100644 index 82821ccb2f9..00000000000 --- 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 43d0c1aece2..00000000000 --- 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 037a87ec499..00000000000 --- 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 034b5924894..00000000000 --- 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 184cefc4d83..00000000000 --- 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 cab0c09bc35..00000000000 --- 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 00b31384587..00000000000 --- 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-chzla1.ads b/gcc/ada/a-chzla1.ads deleted file mode 100644 index cd360d4cb93..00000000000 --- 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 89a7d63463d..00000000000 --- 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 58c1e938ebf..00000000000 --- 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 44dc32d98ca..00000000000 --- 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-cihase.adb b/gcc/ada/a-cihase.adb deleted file mode 100644 index 6d913cbdeec..00000000000 --- 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 2eae9d22d2f..00000000000 --- 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 756b512c990..00000000000 --- 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 7edb0d13ab0..00000000000 --- 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 5d07151271d..00000000000 --- 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 fa657552a1a..00000000000 --- 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 4bf00c61cbd..00000000000 --- 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 4eab5b1dd49..00000000000 --- 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 6ebc1432162..00000000000 --- 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 2e1c018e188..00000000000 --- 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-coboho.adb b/gcc/ada/a-coboho.adb deleted file mode 100644 index 75fc638759f..00000000000 --- 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 67b27f25d6d..00000000000 --- 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 59d6c27350a..00000000000 --- 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 c3157029344..00000000000 --- 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-cogeso.adb b/gcc/ada/a-cogeso.adb deleted file mode 100644 index fc2198cb4b1..00000000000 --- 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 ebf805ab79f..00000000000 --- 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-cohata.ads b/gcc/ada/a-cohata.ads deleted file mode 100644 index c83e8c0081c..00000000000 --- 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 3373dbdfd38..00000000000 --- 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 e5dfb543256..00000000000 --- 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 e9f40aca207..00000000000 --- 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 7cfd193ca3c..00000000000 --- 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 3c1972771f6..00000000000 --- 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 8be2121dee1..00000000000 --- 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 bd2f9d25c6f..00000000000 --- 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 224e70e8dd4..00000000000 --- 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 31a285591f5..00000000000 --- 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 a4545092574..00000000000 --- 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-comutr.adb b/gcc/ada/a-comutr.adb deleted file mode 100644 index 7804b0f574f..00000000000 --- 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 ef556969883..00000000000 --- 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 864b217367e..00000000000 --- 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 008ef8a869d..00000000000 --- 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-convec.adb b/gcc/ada/a-convec.adb deleted file mode 100644 index d77e011c202..00000000000 --- 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 5e0de79c227..00000000000 --- 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 6083b4cf45b..00000000000 --- 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 3034a2ec850..00000000000 --- 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 75969d0596b..00000000000 --- 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 5fd8a81edd2..00000000000 --- 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 78345c9ac81..00000000000 --- 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 1260fba05cc..00000000000 --- 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 95eff8bb587..00000000000 --- 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 33af3e19194..00000000000 --- 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-crbltr.ads b/gcc/ada/a-crbltr.ads deleted file mode 100644 index 73ed9ae6741..00000000000 --- 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 10a9e92ba0d..00000000000 --- 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 c93dfe7ba6a..00000000000 --- 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.ads b/gcc/ada/a-crbtgo.ads deleted file mode 100644 index 4c197417ae6..00000000000 --- 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 f228ef0de4b..00000000000 --- 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 151d3f94a0b..00000000000 --- 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 c9957a35d28..00000000000 --- 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 5d1bbacfc63..00000000000 --- 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 591673e7d60..00000000000 --- 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 4183dcba1fe..00000000000 --- 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 7efdbf4b2a3..00000000000 --- 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 48c28b3e248..00000000000 --- 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 7170c157f5b..00000000000 --- 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 b9a9fe54965..00000000000 --- 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 f8e47a8a62d..00000000000 --- 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-diocst.adb b/gcc/ada/a-diocst.adb deleted file mode 100644 index d685dc2f77b..00000000000 --- 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 c4fa5e14c9e..00000000000 --- 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.ads b/gcc/ada/a-direct.ads deleted file mode 100644 index a308c004925..00000000000 --- 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.ads b/gcc/ada/a-direio.ads deleted file mode 100644 index e53e9c1abbf..00000000000 --- 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.adb b/gcc/ada/a-dirval.adb deleted file mode 100644 index 7a08500a232..00000000000 --- 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 9505dffd6fa..00000000000 --- 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 f70eff0edc0..00000000000 --- 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 8d772b01f52..00000000000 --- 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 6ef2e0339f2..00000000000 --- 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 1e36373baa7..00000000000 --- 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 85368f8bf95..00000000000 --- 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-excach.adb b/gcc/ada/a-excach.adb deleted file mode 100644 index b1cc22b94bf..00000000000 --- 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-excpol-abort.adb b/gcc/ada/a-excpol-abort.adb deleted file mode 100644 index d4f9a078657..00000000000 --- 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 07a6e6123ff..00000000000 --- 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 03e46424982..00000000000 --- 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 664bd75221f..00000000000 --- 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 2a5ffbcf20e..00000000000 --- 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 91fb5f5cd67..00000000000 --- 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 2a6f82b83df..00000000000 --- 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 1ff9481eb14..00000000000 --- 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 3d6e45bcf6d..00000000000 --- 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 a1f420efc91..00000000000 --- 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-locale.adb b/gcc/ada/a-locale.adb deleted file mode 100644 index 60ad079d43a..00000000000 --- 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-ngcefu.adb b/gcc/ada/a-ngcefu.adb deleted file mode 100644 index b241f2718a0..00000000000 --- 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-ngcoar.adb b/gcc/ada/a-ngcoar.adb deleted file mode 100644 index bee1bc1fff9..00000000000 --- 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-ngcoty.adb b/gcc/ada/a-ngcoty.adb deleted file mode 100644 index 7cf48713a6b..00000000000 --- 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 0b011e1efa3..00000000000 --- 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 e7a75eea8cf..00000000000 --- 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-ngrear.adb b/gcc/ada/a-ngrear.adb deleted file mode 100644 index 64df675c1a0..00000000000 --- 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 2f38b9051eb..00000000000 --- 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-nudira.adb b/gcc/ada/a-nudira.adb deleted file mode 100644 index 2e83600ffd2..00000000000 --- 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 c2a7382cad9..00000000000 --- 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-nuflra.adb b/gcc/ada/a-nuflra.adb deleted file mode 100644 index add19d453c2..00000000000 --- 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 ea4992c5a0c..00000000000 --- 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 3c4a1013036..00000000000 --- 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 a548798826a..00000000000 --- 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 3f59fabdce6..00000000000 --- 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 25fcd2d420e..00000000000 --- 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 b6690d13abe..00000000000 --- 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 4c98ef1604a..00000000000 --- 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 2e7d1e38dbf..00000000000 --- 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-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb deleted file mode 100644 index abf7773522a..00000000000 --- 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 1cf1cbc9cc4..00000000000 --- 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 8306399eb8a..00000000000 --- 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 4045182343a..00000000000 --- 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 f6daa90ff1d..00000000000 --- 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 9ad296fe090..00000000000 --- 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 78000176844..00000000000 --- 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 115c7220606..00000000000 --- 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 8c69290e0d0..00000000000 --- 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 c291f53db9a..00000000000 --- 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 e2ce4d3f384..00000000000 --- 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 d7284110aef..00000000000 --- 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-secain.adb b/gcc/ada/a-secain.adb deleted file mode 100644 index e77198ead1e..00000000000 --- 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 c5e747b1386..00000000000 --- 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 f180fd68cd5..00000000000 --- 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 8dbfb0fcd48..00000000000 --- 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 592b69166c9..00000000000 --- 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 86f60f68944..00000000000 --- 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 8af21fe9e55..00000000000 --- 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-shcain.adb b/gcc/ada/a-shcain.adb deleted file mode 100644 index 8c7ccbef441..00000000000 --- 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 fa3123c9685..00000000000 --- 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 cfffa3080c9..00000000000 --- 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 85063b4fb6a..00000000000 --- 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-slcain.adb b/gcc/ada/a-slcain.adb deleted file mode 100644 index 5e3fd6b0cb8..00000000000 --- 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 1327c30dd08..00000000000 --- 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.ads b/gcc/ada/a-ssicst.ads deleted file mode 100644 index 733f54e91ac..00000000000 --- 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-stboha.adb b/gcc/ada/a-stboha.adb deleted file mode 100644 index 97ae52666bf..00000000000 --- 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-stmaco.ads b/gcc/ada/a-stmaco.ads deleted file mode 100644 index 92d70219602..00000000000 --- 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 50b7665b748..00000000000 --- 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-strbou.adb b/gcc/ada/a-strbou.adb deleted file mode 100644 index 370371fd5ca..00000000000 --- 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 5e7a9c71d15..00000000000 --- 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 a22161d16da..00000000000 --- 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-strhas.adb b/gcc/ada/a-strhas.adb deleted file mode 100644 index f0ee0602f5c..00000000000 --- 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-strmap.adb b/gcc/ada/a-strmap.adb deleted file mode 100644 index 071c02a68b1..00000000000 --- 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 a882e9c4ed5..00000000000 --- 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 df267c1d7f9..00000000000 --- 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-strsup.adb b/gcc/ada/a-strsup.adb deleted file mode 100644 index 50df7dd48b4..00000000000 --- 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 d43a560a543..00000000000 --- 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 2199f647b8a..00000000000 --- 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 c5f96b38f17..00000000000 --- 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 b4c3cddf983..00000000000 --- 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 334146665ae..00000000000 --- 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 fb3b59cc882..00000000000 --- 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 4049163fa8f..00000000000 --- 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 6ca416243b7..00000000000 --- 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 c6d2bc43ac3..00000000000 --- 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 06cffc589a6..00000000000 --- 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 064a34294ae..00000000000 --- 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-stuten.adb b/gcc/ada/a-stuten.adb deleted file mode 100644 index fc669b56ee4..00000000000 --- 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-stwibo.adb b/gcc/ada/a-stwibo.adb deleted file mode 100644 index 3f784f64b37..00000000000 --- 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 3d098b3d4d0..00000000000 --- 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 c586791100b..00000000000 --- 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-stwiha.adb b/gcc/ada/a-stwiha.adb deleted file mode 100644 index 4c2b15d3ffa..00000000000 --- 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-stwima.adb b/gcc/ada/a-stwima.adb deleted file mode 100644 index ed6ef60f683..00000000000 --- 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 8863a442b7a..00000000000 --- 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 09ac7830c8a..00000000000 --- 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-stwisu.adb b/gcc/ada/a-stwisu.adb deleted file mode 100644 index 10c2b237b8f..00000000000 --- 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 e2f3c570040..00000000000 --- 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 34811b7b90b..00000000000 --- 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 e37b1c23181..00000000000 --- 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 06f9d369107..00000000000 --- 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 dcec88977e3..00000000000 --- 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 76e7292e6f4..00000000000 --- 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 d7d3f52f2e7..00000000000 --- 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 b0087831d94..00000000000 --- 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-stzhas.adb b/gcc/ada/a-stzhas.adb deleted file mode 100644 index a48fd0346a9..00000000000 --- 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-stzmap.adb b/gcc/ada/a-stzmap.adb deleted file mode 100644 index b331a0f944b..00000000000 --- 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 bd63fdd8224..00000000000 --- 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 7b4f63507fd..00000000000 --- 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-stzsup.adb b/gcc/ada/a-stzsup.adb deleted file mode 100644 index acd003591ee..00000000000 --- 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 728b0bc71f8..00000000000 --- 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 bf2ed256334..00000000000 --- 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 d84c86becc7..00000000000 --- 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 267df9e6912..00000000000 --- 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 fa7bc17d93d..00000000000 --- 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 73ebae57156..00000000000 --- 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 08960241c8e..00000000000 --- 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 54d142d7a65..00000000000 --- 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-suenst.adb b/gcc/ada/a-suenst.adb deleted file mode 100644 index 2ed5c2c0c6c..00000000000 --- 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-suewst.adb b/gcc/ada/a-suewst.adb deleted file mode 100644 index c0855d3e0d7..00000000000 --- 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-suezst.adb b/gcc/ada/a-suezst.adb deleted file mode 100644 index 81d0f670fed..00000000000 --- 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-suhcin.adb b/gcc/ada/a-suhcin.adb deleted file mode 100644 index 0417c15db24..00000000000 --- 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 180d4a4391a..00000000000 --- 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 9f1f3c4aca9..00000000000 --- 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 fafb546ca77..00000000000 --- 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 d50ed776775..00000000000 --- 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 0a67067dcf6..00000000000 --- 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 2b4840710b2..00000000000 --- 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 643b5b0e654..00000000000 --- 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-swmwco.ads b/gcc/ada/a-swmwco.ads deleted file mode 100644 index af46e34a6d7..00000000000 --- 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 ad397b8c5b3..00000000000 --- 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 004a5d4ac1a..00000000000 --- 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 78fa5dbb865..00000000000 --- 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 e3674478325..00000000000 --- 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-swuwti-shared.adb b/gcc/ada/a-swuwti-shared.adb deleted file mode 100644 index 9cf7c0ad559..00000000000 --- 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 65f26cd8be0..00000000000 --- 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 a3b742eec03..00000000000 --- 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 9ee1e91374e..00000000000 --- 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-szmzco.ads b/gcc/ada/a-szmzco.ads deleted file mode 100644 index 6fbb7bf7777..00000000000 --- 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 87b2cb40d15..00000000000 --- 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 7ab9cc5acd4..00000000000 --- 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 6115330d94b..00000000000 --- 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 13cb19b7dcd..00000000000 --- 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-szuzti-shared.adb b/gcc/ada/a-szuzti-shared.adb deleted file mode 100644 index 247ccb2bcd5..00000000000 --- 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 25feb202f91..00000000000 --- 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 f84a34ed058..00000000000 --- 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-teioed.adb b/gcc/ada/a-teioed.adb deleted file mode 100644 index 3c3e874f0d3..00000000000 --- 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 bc2842abdf3..00000000000 --- 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.ads b/gcc/ada/a-textio.ads deleted file mode 100644 index d04b2e9e72f..00000000000 --- 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-tiboio.adb b/gcc/ada/a-tiboio.adb deleted file mode 100644 index dcc91be86b9..00000000000 --- 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-ticoau.adb b/gcc/ada/a-ticoau.adb deleted file mode 100644 index 0601ef064f0..00000000000 --- 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 b8fe9dfacce..00000000000 --- 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 f06f8477857..00000000000 --- 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 9b71b97de21..00000000000 --- 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 2790bed68d7..00000000000 --- 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 ae75fc11bd0..00000000000 --- 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 5dceb128f90..00000000000 --- 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 47acdd6ab45..00000000000 --- 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 6ee9bbadc60..00000000000 --- 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 525c2233610..00000000000 --- 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 e98f410eee9..00000000000 --- 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-tifiio.adb b/gcc/ada/a-tifiio.adb deleted file mode 100644 index 2fd8b5421f2..00000000000 --- 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-tiflau.adb b/gcc/ada/a-tiflau.adb deleted file mode 100644 index c7115f65768..00000000000 --- 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 4be17586cca..00000000000 --- 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 af0f1ab7ca5..00000000000 --- 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 89eec9932cf..00000000000 --- 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 218aec87b8a..00000000000 --- 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 4de4739dcbe..00000000000 --- 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-tiinau.adb b/gcc/ada/a-tiinau.adb deleted file mode 100644 index 5d08dc09f7c..00000000000 --- 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 ee2ca23e600..00000000000 --- 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 f477dbf77a1..00000000000 --- 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 459d6fe5a6e..00000000000 --- 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 2fceb8a96ac..00000000000 --- 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 3520b5688ce..00000000000 --- 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 b000cd517cb..00000000000 --- 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 112adf4b821..00000000000 --- 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 3015f31a062..00000000000 --- 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 bb6c5b11844..00000000000 --- 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 a61e2b92e07..00000000000 --- 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 066df9fc8b2..00000000000 --- 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 3b8f9ce6dab..00000000000 --- 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-undesu.adb b/gcc/ada/a-undesu.adb deleted file mode 100644 index d2bd292e145..00000000000 --- 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-wichha.adb b/gcc/ada/a-wichha.adb deleted file mode 100644 index 8d02236111c..00000000000 --- 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-wichun.adb b/gcc/ada/a-wichun.adb deleted file mode 100644 index b36d4a435d4..00000000000 --- 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 bf7e08f5472..00000000000 --- 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-witeio.ads b/gcc/ada/a-witeio.ads deleted file mode 100644 index 70375f2215f..00000000000 --- 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 6b3f656b670..00000000000 --- 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 5d6548eadc5..00000000000 --- 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 5a7f438bf94..00000000000 --- 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 f5fa1e2c6fe..00000000000 --- 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 06f5da54ebb..00000000000 --- 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-wtcstr.adb b/gcc/ada/a-wtcstr.adb deleted file mode 100644 index 4be744a2a4b..00000000000 --- 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 af2d37a6156..00000000000 --- 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 78b10299b2c..00000000000 --- 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 430888930ea..00000000000 --- 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-wtedit.adb b/gcc/ada/a-wtedit.adb deleted file mode 100644 index 32d62b97087..00000000000 --- 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 edc17c55898..00000000000 --- 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 709703e95af..00000000000 --- 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 05fc9d7ff94..00000000000 --- 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 c5dea39da60..00000000000 --- 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-wtfiio.adb b/gcc/ada/a-wtfiio.adb deleted file mode 100644 index c8f5473c47a..00000000000 --- 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-wtflau.adb b/gcc/ada/a-wtflau.adb deleted file mode 100644 index 718ec660bfa..00000000000 --- 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 96d03d37562..00000000000 --- 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 af34e9465b7..00000000000 --- 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-wtgeau.adb b/gcc/ada/a-wtgeau.adb deleted file mode 100644 index 7e2777313f0..00000000000 --- 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 fabd543fd66..00000000000 --- 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 8b4b1e65a1e..00000000000 --- 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 7c7927db078..00000000000 --- 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 507145f98e7..00000000000 --- 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-wtmoau.adb b/gcc/ada/a-wtmoau.adb deleted file mode 100644 index 25c72ecfcd7..00000000000 --- 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 a9c2bdcfd1c..00000000000 --- 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 ce31ed5e2e0..00000000000 --- 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 9ea1620d1a5..00000000000 --- 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 ed64bdd5f8c..00000000000 --- 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-wwboio.adb b/gcc/ada/a-wwboio.adb deleted file mode 100644 index 37a101defae..00000000000 --- 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-zchhan.adb b/gcc/ada/a-zchhan.adb deleted file mode 100644 index 54db3ba8130..00000000000 --- 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-zchuni.adb b/gcc/ada/a-zchuni.adb deleted file mode 100644 index faa5c10a131..00000000000 --- 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 98989d6a60a..00000000000 --- 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 77dbc8b5734..00000000000 --- 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 ae6592d4ccc..00000000000 --- 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 d9c365c45f3..00000000000 --- 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-ztcoio.adb b/gcc/ada/a-ztcoio.adb deleted file mode 100644 index c5d21a1a2d2..00000000000 --- 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-ztcstr.adb b/gcc/ada/a-ztcstr.adb deleted file mode 100644 index 7d61d717ed1..00000000000 --- 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 75dc89bce56..00000000000 --- 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 38450fcb011..00000000000 --- 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 96725929b16..00000000000 --- 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 52f8820a787..00000000000 --- 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-ztedit.adb b/gcc/ada/a-ztedit.adb deleted file mode 100644 index bc759e05bb4..00000000000 --- 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 db840d04d29..00000000000 --- 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 8df795e6853..00000000000 --- 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 5e127122fcf..00000000000 --- 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 74b0ec932fe..00000000000 --- 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-ztexio.ads b/gcc/ada/a-ztexio.ads deleted file mode 100644 index ef90c920ed1..00000000000 --- 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 a4eaed969c5..00000000000 --- 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-ztflau.adb b/gcc/ada/a-ztflau.adb deleted file mode 100644 index 55dd2da5484..00000000000 --- 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 4323c49c289..00000000000 --- 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 1530bcba6bd..00000000000 --- 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-ztgeau.adb b/gcc/ada/a-ztgeau.adb deleted file mode 100644 index 7f182a13fe8..00000000000 --- 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 26ca68e9a6a..00000000000 --- 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 735e51fc4e3..00000000000 --- 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 8c041bfc36b..00000000000 --- 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 93e4d280960..00000000000 --- 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-ztmoau.adb b/gcc/ada/a-ztmoau.adb deleted file mode 100644 index dbcf37808ee..00000000000 --- 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 0caffa0d4bf..00000000000 --- 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 041f8dc7c59..00000000000 --- 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-zttest.adb b/gcc/ada/a-zttest.adb deleted file mode 100644 index c4626a89f29..00000000000 --- 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-zzboio.adb b/gcc/ada/a-zzboio.adb deleted file mode 100644 index c1efb2f7928..00000000000 --- 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/ada.ads b/gcc/ada/ada.ads deleted file mode 100644 index 4c2a3d00e50..00000000000 --- 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/g-allein.ads b/gcc/ada/g-allein.ads deleted file mode 100644 index bbadf8e7088..00000000000 --- 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 962401d9885..00000000000 --- 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 66718c1732f..00000000000 --- 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 edd6c98476b..00000000000 --- 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 93d291e2e1b..00000000000 --- 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-alveop.adb b/gcc/ada/g-alveop.adb deleted file mode 100644 index 0a7b1d3f083..00000000000 --- 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 82bc5f48793..00000000000 --- 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 06e824eb18a..00000000000 --- 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 8d8d8560834..00000000000 --- 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 f3eaf809f97..00000000000 --- 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 ce3158c5ef3..00000000000 --- 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 5771100b678..00000000000 --- 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 c52403e5ddf..00000000000 --- 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 13e414d46fa..00000000000 --- 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 e3c181fafa2..00000000000 --- 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 de2c3892d1c..00000000000 --- 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 b91d8e1c792..00000000000 --- 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 ca44d6b91cb..00000000000 --- 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 919f6ab54d5..00000000000 --- 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 677c6423934..00000000000 --- 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 5b7d10263a4..00000000000 --- 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 0b389f5d403..00000000000 --- 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 a58006e6dcc..00000000000 --- 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 9628bbc5da9..00000000000 --- 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 35656fc8045..00000000000 --- 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 8f309de7251..00000000000 --- 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 3559130e1f1..00000000000 --- 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 2fc825ddc8d..00000000000 --- 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 18c46cb49e2..00000000000 --- 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-cgi.ads b/gcc/ada/g-cgi.ads deleted file mode 100644 index faaa16b3474..00000000000 --- 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 f0d42251d2d..00000000000 --- 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 e6657a2c606..00000000000 --- 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 6cc45e933e6..00000000000 --- 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 7a1e979fd12..00000000000 --- 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.ads b/gcc/ada/g-comlin.ads deleted file mode 100644 index f7585085ac6..00000000000 --- 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.ads b/gcc/ada/g-comver.ads deleted file mode 100644 index 037a21af012..00000000000 --- 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 d89cf0ccac3..00000000000 --- 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 60105e6f98c..00000000000 --- 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 14d592a835a..00000000000 --- 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 61d37a34682..00000000000 --- 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 edd7dc637fa..00000000000 --- 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 0f068c28a83..00000000000 --- 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 47fffab1871..00000000000 --- 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.ads b/gcc/ada/g-debpoo.ads deleted file mode 100644 index 108422a3174..00000000000 --- 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 8a40e994e3c..00000000000 --- 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 dd860a74b56..00000000000 --- 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 ab8d06c2b7f..00000000000 --- 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 d59f10dcb20..00000000000 --- 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 5e0cb4d5526..00000000000 --- 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 65bd65c0229..00000000000 --- 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 aac30b957fb..00000000000 --- 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.ads b/gcc/ada/g-dirope.ads deleted file mode 100644 index 1b04b94615d..00000000000 --- 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-eacodu.adb b/gcc/ada/g-eacodu.adb deleted file mode 100644 index f622552c8f3..00000000000 --- 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 80ca6d04d18..00000000000 --- 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 af982760f02..00000000000 --- 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 2422a2d24c6..00000000000 --- 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 ed454cefcde..00000000000 --- 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 44f067ddbb7..00000000000 --- 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-exctra.adb b/gcc/ada/g-exctra.adb deleted file mode 100644 index 8844fcf09e9..00000000000 --- 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 aa264ba12a0..00000000000 --- 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 d7bb2dda378..00000000000 --- 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 0dc634110ee..00000000000 --- 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 00615f9e883..00000000000 --- 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 10e0f81147e..00000000000 --- 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 a7ab7f6d90f..00000000000 --- 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-heasor.adb b/gcc/ada/g-heasor.adb deleted file mode 100644 index ec915155c24..00000000000 --- 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 edc9294e6ef..00000000000 --- 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 cf7202da324..00000000000 --- 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 e270172c048..00000000000 --- 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 ae8b6f18814..00000000000 --- 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 57b9912375f..00000000000 --- 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 309de178515..00000000000 --- 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 000756071bf..00000000000 --- 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 8a08f2468b3..00000000000 --- 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 b7383cf7514..00000000000 --- 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 6891921101a..00000000000 --- 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 2e0b0caa279..00000000000 --- 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 3726ac6c5d0..00000000000 --- 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 5449dc6e32d..00000000000 --- 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 3e52cc0625f..00000000000 --- 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 c5d8c8b7291..00000000000 --- 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 c415a24cfcf..00000000000 --- 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 1d59069d112..00000000000 --- 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 4deac482b52..00000000000 --- 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 28d20c99dc4..00000000000 --- 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 81fd6b0d90e..00000000000 --- 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 bee7991ce64..00000000000 --- 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 0d56e2189e9..00000000000 --- 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 822b760711e..00000000000 --- 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 5d261093f04..00000000000 --- 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 ab9a0a07f8b..00000000000 --- 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 dafd090d467..00000000000 --- 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 76ecb02356f..00000000000 --- 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 67875a66355..00000000000 --- 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 3e802eeeaa9..00000000000 --- 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 cf2889c4581..00000000000 --- 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 af2423680fd..00000000000 --- 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 6d5b7df473a..00000000000 --- 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 4d989630151..00000000000 --- 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 0222a1079ef..00000000000 --- 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 5e7dc763f73..00000000000 --- 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 388dbda24c2..00000000000 --- 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 855f78736ad..00000000000 --- 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-sechas.adb b/gcc/ada/g-sechas.adb deleted file mode 100644 index 59a598d74c8..00000000000 --- 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-sehamd.adb b/gcc/ada/g-sehamd.adb deleted file mode 100644 index cd8a1f51686..00000000000 --- 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 23406363275..00000000000 --- 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 b5e96895327..00000000000 --- 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 c3bbce1edb4..00000000000 --- 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 4140106c8d6..00000000000 --- 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 dabbfcfd405..00000000000 --- 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 c2b511c59c7..00000000000 --- 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 f185a7737df..00000000000 --- 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 a1658b36cf6..00000000000 --- 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 edc6b43d9c0..00000000000 --- 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 2a1c0e1dc60..00000000000 --- 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 0520a5efe31..00000000000 --- 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 91088433c00..00000000000 --- 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 0047da06ca3..00000000000 --- 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 e75d9493d45..00000000000 --- 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 c9845f14d90..00000000000 --- 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 4495a150db8..00000000000 --- 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 330337ceb9f..00000000000 --- 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 4b27c7db1fe..00000000000 --- 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 dcdb23690eb..00000000000 --- 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 e2f9f9137f4..00000000000 --- 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 4b904d911e8..00000000000 --- 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 b4a56226b73..00000000000 --- 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 5a24317a5a0..00000000000 --- 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-socthi-dummy.adb b/gcc/ada/g-socthi-dummy.adb deleted file mode 100644 index 625eb82754e..00000000000 --- 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 47b5e6cfd78..00000000000 --- 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 6ce2fb6cc42..00000000000 --- 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 202297d5732..00000000000 --- 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 0e3f7d7dab7..00000000000 --- 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 8fe96ce7a36..00000000000 --- 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 6f6fd376968..00000000000 --- 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 062ad186fec..00000000000 --- 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 33c63fd6382..00000000000 --- 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 cd7e3bb78dd..00000000000 --- 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 3b39858f104..00000000000 --- 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 4dd2b3f760a..00000000000 --- 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 473a06889da..00000000000 --- 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 4e8fbdee8c3..00000000000 --- 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 c25f4edc701..00000000000 --- 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 83d23d4f672..00000000000 --- 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 bdc38544bb4..00000000000 --- 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 908250d25d0..00000000000 --- 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 0e8c7c46b28..00000000000 --- 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 7b4da4a2f13..00000000000 --- 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.ads b/gcc/ada/g-spipat.ads deleted file mode 100644 index fe10fed0f1f..00000000000 --- 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 26753bd0b11..00000000000 --- 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 b07a21451fc..00000000000 --- 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 7d5b82607e8..00000000000 --- 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 1cc06de6d0d..00000000000 --- 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 7bbc854645d..00000000000 --- 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 60d3577ad41..00000000000 --- 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 c40706474a4..00000000000 --- 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 ceccba0ba01..00000000000 --- 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 c20b678c9fa..00000000000 --- 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 970ef2cd1fe..00000000000 --- 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 a25938ed2ff..00000000000 --- 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 31851b3ee09..00000000000 --- 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 2b6aeeb4856..00000000000 --- 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 87e887fa7a5..00000000000 --- 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-tasloc.adb b/gcc/ada/g-tasloc.adb deleted file mode 100644 index 3df8b7fc882..00000000000 --- 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 4bb8227fdf7..00000000000 --- 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 50d4f702324..00000000000 --- 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 8f35e7b959f..00000000000 --- 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 157d8b620cd..00000000000 --- 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 e71a0552cfd..00000000000 --- 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 3fdfd1adad7..00000000000 --- 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 1d9b3f7ec21..00000000000 --- 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 43c1bea5469..00000000000 --- 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 12aaba760f1..00000000000 --- 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 b6c2a56b321..00000000000 --- 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 190eabebbfe..00000000000 --- 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 3f566f1af59..00000000000 --- 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 062cea4579c..00000000000 --- 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 1f7614f5c07..00000000000 --- 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 2dd36da3207..00000000000 --- 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 39f19a6717a..00000000000 --- 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 631279518a4..00000000000 --- 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 af5bf2d855c..00000000000 --- 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 de87324b7a9..00000000000 --- 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 e38a1f9e06f..b9d06b025ad 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 ef3dbec1079..4fdee80b4aa 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 01d69122fcf..00000000000 --- 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-cexten.ads b/gcc/ada/i-cexten.ads deleted file mode 100644 index e256dec22ba..00000000000 --- 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 bd331b48c92..00000000000 --- 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 9edcc0194da..00000000000 --- 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 ddf33dae6fe..00000000000 --- 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 b3943b5fb98..00000000000 --- 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 d831206b47b..00000000000 --- 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 5927e5f95c2..00000000000 --- 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 a2705065b17..00000000000 --- 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 833a69ac6f7..00000000000 --- 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 532089d7145..00000000000 --- 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-pacdec.adb b/gcc/ada/i-pacdec.adb deleted file mode 100644 index bb6c21a07cf..00000000000 --- 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 ce3f0f2e6c3..00000000000 --- 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 4d480e0519f..00000000000 --- 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 dc695469692..00000000000 --- 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 549c3c7badb..00000000000 --- 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 81c42993730..00000000000 --- 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 3bda2f46651..00000000000 --- 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/a-intnam-dragonfly.ads b/gcc/ada/libgnarl/a-intnam-dragonfly.ads similarity index 100% rename from gcc/ada/a-intnam-dragonfly.ads rename to gcc/ada/libgnarl/a-intnam-dragonfly.ads diff --git a/gcc/ada/a-intnam-rtems.ads b/gcc/ada/libgnarl/a-intnam-rtems.ads similarity index 100% rename from gcc/ada/a-intnam-rtems.ads rename to gcc/ada/libgnarl/a-intnam-rtems.ads diff --git a/gcc/ada/libgnat/a-assert.adb b/gcc/ada/libgnat/a-assert.adb new file mode 100644 index 00000000000..f7f69434cc9 --- /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 00000000000..caa5aa01f9d --- /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 00000000000..740aa171b0c --- /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 00000000000..3965d4227da --- /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 00000000000..77065f2865d --- /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 00000000000..73bd921f5dc --- /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 00000000000..c17d1f449e7 --- /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 00000000000..f62e89e68ac --- /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 00000000000..bde488a0f46 --- /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 00000000000..66429dc55a6 --- /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 00000000000..7721d8d04ea --- /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 00000000000..6579dc124a2 --- /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 00000000000..c10e790fb9c --- /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 00000000000..58cb4fb18ec --- /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 00000000000..480facfeaf4 --- /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/a-catizo.ads b/gcc/ada/libgnat/a-catizo.ads similarity index 100% rename from gcc/ada/a-catizo.ads rename to gcc/ada/libgnat/a-catizo.ads diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb similarity index 100% rename from gcc/ada/a-cbdlli.adb rename to gcc/ada/libgnat/a-cbdlli.adb diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads new file mode 100644 index 00000000000..cfcbecf2bff --- /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 00000000000..57948d23b3b --- /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 00000000000..9d36e152700 --- /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 00000000000..fbf16a222c3 --- /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 00000000000..3bf369905b9 --- /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 00000000000..f1145de89bb --- /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 00000000000..a5d7ae35a37 --- /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 00000000000..7dca13b3aee --- /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 00000000000..cced3226879 --- /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 00000000000..7a25cd76766 --- /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 00000000000..e9bd8b4becc --- /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 00000000000..abb2fe92b7f --- /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/a-cbprqu.ads b/gcc/ada/libgnat/a-cbprqu.ads similarity index 100% rename from gcc/ada/a-cbprqu.ads rename to gcc/ada/libgnat/a-cbprqu.ads diff --git a/gcc/ada/libgnat/a-cbsyqu.adb b/gcc/ada/libgnat/a-cbsyqu.adb new file mode 100644 index 00000000000..17dc62c50d9 --- /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 00000000000..f734a4d10cc --- /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 00000000000..27275aa3871 --- /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 00000000000..e6d587a8b52 --- /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/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb similarity index 100% rename from gcc/ada/a-cfdlli.adb rename to gcc/ada/libgnat/a-cfdlli.adb diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads similarity index 100% rename from gcc/ada/a-cfdlli.ads rename to gcc/ada/libgnat/a-cfdlli.ads diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb similarity index 100% rename from gcc/ada/a-cfhama.adb rename to gcc/ada/libgnat/a-cfhama.adb diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads similarity index 100% rename from gcc/ada/a-cfhama.ads rename to gcc/ada/libgnat/a-cfhama.ads diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb similarity index 100% rename from gcc/ada/a-cfhase.adb rename to gcc/ada/libgnat/a-cfhase.adb diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads similarity index 100% rename from gcc/ada/a-cfhase.ads rename to gcc/ada/libgnat/a-cfhase.ads diff --git a/gcc/ada/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb similarity index 100% rename from gcc/ada/a-cfinve.adb rename to gcc/ada/libgnat/a-cfinve.adb diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads similarity index 100% rename from gcc/ada/a-cfinve.ads rename to gcc/ada/libgnat/a-cfinve.ads diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb similarity index 100% rename from gcc/ada/a-cforma.adb rename to gcc/ada/libgnat/a-cforma.adb diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads similarity index 100% rename from gcc/ada/a-cforma.ads rename to gcc/ada/libgnat/a-cforma.ads diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb similarity index 100% rename from gcc/ada/a-cforse.adb rename to gcc/ada/libgnat/a-cforse.adb diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads similarity index 100% rename from gcc/ada/a-cforse.ads rename to gcc/ada/libgnat/a-cforse.ads diff --git a/gcc/ada/libgnat/a-cgaaso.adb b/gcc/ada/libgnat/a-cgaaso.adb new file mode 100644 index 00000000000..2cbebbad914 --- /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 00000000000..b99a5aa6d94 --- /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 00000000000..0863ff13820 --- /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/a-cgarso.ads b/gcc/ada/libgnat/a-cgarso.ads similarity index 100% rename from gcc/ada/a-cgarso.ads rename to gcc/ada/libgnat/a-cgarso.ads diff --git a/gcc/ada/libgnat/a-cgcaso.adb b/gcc/ada/libgnat/a-cgcaso.adb new file mode 100644 index 00000000000..ac8215a0c9e --- /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/a-cgcaso.ads b/gcc/ada/libgnat/a-cgcaso.ads similarity index 100% rename from gcc/ada/a-cgcaso.ads rename to gcc/ada/libgnat/a-cgcaso.ads diff --git a/gcc/ada/libgnat/a-chacon.adb b/gcc/ada/libgnat/a-chacon.adb new file mode 100644 index 00000000000..2fddc0482db --- /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 00000000000..098019cbef5 --- /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 00000000000..4f9b54b169e --- /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 00000000000..60a6d493a93 --- /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/a-charac.ads b/gcc/ada/libgnat/a-charac.ads similarity index 100% rename from gcc/ada/a-charac.ads rename to gcc/ada/libgnat/a-charac.ads diff --git a/gcc/ada/a-chlat1.ads b/gcc/ada/libgnat/a-chlat1.ads similarity index 100% rename from gcc/ada/a-chlat1.ads rename to gcc/ada/libgnat/a-chlat1.ads diff --git a/gcc/ada/libgnat/a-chlat9.ads b/gcc/ada/libgnat/a-chlat9.ads new file mode 100644 index 00000000000..27334d837fd --- /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 00000000000..0101ed65cbb --- /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 00000000000..ee59d2e2d77 --- /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 00000000000..91ca1680c37 --- /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 00000000000..832bac46470 --- /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 00000000000..69297986bda --- /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 00000000000..26c2a55d0e8 --- /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/a-chtgop.adb b/gcc/ada/libgnat/a-chtgop.adb similarity index 100% rename from gcc/ada/a-chtgop.adb rename to gcc/ada/libgnat/a-chtgop.adb diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/libgnat/a-chtgop.ads similarity index 100% rename from gcc/ada/a-chtgop.ads rename to gcc/ada/libgnat/a-chtgop.ads diff --git a/gcc/ada/libgnat/a-chzla1.ads b/gcc/ada/libgnat/a-chzla1.ads new file mode 100644 index 00000000000..f04a6ceaf3a --- /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 00000000000..a5b3965af2a --- /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 00000000000..55445e30832 --- /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 00000000000..764d1bd6083 --- /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/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb similarity index 100% rename from gcc/ada/a-cihama.adb rename to gcc/ada/libgnat/a-cihama.adb diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads similarity index 100% rename from gcc/ada/a-cihama.ads rename to gcc/ada/libgnat/a-cihama.ads diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb new file mode 100644 index 00000000000..af865e2b7f8 --- /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 00000000000..4529a02ac39 --- /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 00000000000..562788f01df --- /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 00000000000..cd97c9f3f67 --- /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 00000000000..339743007ab --- /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 00000000000..6e9c1ef4167 --- /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 00000000000..916df951894 --- /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 00000000000..426924e21c2 --- /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 00000000000..512127ebafb --- /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 00000000000..78750f2d830 --- /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/a-clrefi.adb b/gcc/ada/libgnat/a-clrefi.adb similarity index 100% rename from gcc/ada/a-clrefi.adb rename to gcc/ada/libgnat/a-clrefi.adb diff --git a/gcc/ada/a-clrefi.ads b/gcc/ada/libgnat/a-clrefi.ads similarity index 100% rename from gcc/ada/a-clrefi.ads rename to gcc/ada/libgnat/a-clrefi.ads diff --git a/gcc/ada/libgnat/a-coboho.adb b/gcc/ada/libgnat/a-coboho.adb new file mode 100644 index 00000000000..9696d1c6c76 --- /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 00000000000..130f7f2ea72 --- /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 00000000000..2d0770ae8fd --- /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 00000000000..990dcd1336b --- /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/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb similarity index 100% rename from gcc/ada/a-cofove.adb rename to gcc/ada/libgnat/a-cofove.adb diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads similarity index 100% rename from gcc/ada/a-cofove.ads rename to gcc/ada/libgnat/a-cofove.ads diff --git a/gcc/ada/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb similarity index 100% rename from gcc/ada/a-cofuba.adb rename to gcc/ada/libgnat/a-cofuba.adb diff --git a/gcc/ada/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads similarity index 100% rename from gcc/ada/a-cofuba.ads rename to gcc/ada/libgnat/a-cofuba.ads diff --git a/gcc/ada/a-cofuma.adb b/gcc/ada/libgnat/a-cofuma.adb similarity index 100% rename from gcc/ada/a-cofuma.adb rename to gcc/ada/libgnat/a-cofuma.adb diff --git a/gcc/ada/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads similarity index 100% rename from gcc/ada/a-cofuma.ads rename to gcc/ada/libgnat/a-cofuma.ads diff --git a/gcc/ada/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb similarity index 100% rename from gcc/ada/a-cofuse.adb rename to gcc/ada/libgnat/a-cofuse.adb diff --git a/gcc/ada/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads similarity index 100% rename from gcc/ada/a-cofuse.ads rename to gcc/ada/libgnat/a-cofuse.ads diff --git a/gcc/ada/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb similarity index 100% rename from gcc/ada/a-cofuve.adb rename to gcc/ada/libgnat/a-cofuve.adb diff --git a/gcc/ada/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads similarity index 100% rename from gcc/ada/a-cofuve.ads rename to gcc/ada/libgnat/a-cofuve.ads diff --git a/gcc/ada/libgnat/a-cogeso.adb b/gcc/ada/libgnat/a-cogeso.adb new file mode 100644 index 00000000000..e0a4267ae6b --- /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 00000000000..1151c81ab65 --- /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/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb similarity index 100% rename from gcc/ada/a-cohama.adb rename to gcc/ada/libgnat/a-cohama.adb diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads similarity index 100% rename from gcc/ada/a-cohama.ads rename to gcc/ada/libgnat/a-cohama.ads diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb similarity index 100% rename from gcc/ada/a-cohase.adb rename to gcc/ada/libgnat/a-cohase.adb diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads similarity index 100% rename from gcc/ada/a-cohase.ads rename to gcc/ada/libgnat/a-cohase.ads diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads new file mode 100644 index 00000000000..ea920839843 --- /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 00000000000..e4da421cec5 --- /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 00000000000..3faab9b84e6 --- /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 00000000000..7ac42db83bd --- /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 00000000000..87e6a5832a1 --- /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 00000000000..95431b8010d --- /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 00000000000..dc8e14ffcaa --- /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 00000000000..2720fc34691 --- /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 00000000000..886620facda --- /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 00000000000..907abf2d4ce --- /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 00000000000..c7c6f63ec05 --- /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/a-comlin.adb b/gcc/ada/libgnat/a-comlin.adb similarity index 100% rename from gcc/ada/a-comlin.adb rename to gcc/ada/libgnat/a-comlin.adb diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/libgnat/a-comlin.ads similarity index 100% rename from gcc/ada/a-comlin.ads rename to gcc/ada/libgnat/a-comlin.ads diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb new file mode 100644 index 00000000000..944e51f5722 --- /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 00000000000..a6a6db8d9bb --- /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 00000000000..2e4d32bc3c9 --- /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 00000000000..77a4ead898a --- /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/a-contai.ads b/gcc/ada/libgnat/a-contai.ads similarity index 100% rename from gcc/ada/a-contai.ads rename to gcc/ada/libgnat/a-contai.ads diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb new file mode 100644 index 00000000000..84d6106d5de --- /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 00000000000..8e762cae986 --- /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 00000000000..84f6327f734 --- /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 00000000000..1e3e6f0bb6b --- /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 00000000000..b252d130ba6 --- /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 00000000000..bc91e27eec8 --- /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 00000000000..428b9b93bd0 --- /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 00000000000..3222bfba275 --- /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 00000000000..bc2054d92f3 --- /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 00000000000..4261267a6fc --- /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/a-coteio.ads b/gcc/ada/libgnat/a-coteio.ads similarity index 100% rename from gcc/ada/a-coteio.ads rename to gcc/ada/libgnat/a-coteio.ads diff --git a/gcc/ada/libgnat/a-crbltr.ads b/gcc/ada/libgnat/a-crbltr.ads new file mode 100644 index 00000000000..75df71b7e8c --- /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 00000000000..8eb3c5d0acc --- /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 00000000000..1a9e39e429f --- /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/a-crbtgo.adb b/gcc/ada/libgnat/a-crbtgo.adb similarity index 100% rename from gcc/ada/a-crbtgo.adb rename to gcc/ada/libgnat/a-crbtgo.adb diff --git a/gcc/ada/libgnat/a-crbtgo.ads b/gcc/ada/libgnat/a-crbtgo.ads new file mode 100644 index 00000000000..6cc9d9656a4 --- /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 00000000000..92ec3f3148e --- /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 00000000000..b73ee5a6241 --- /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 00000000000..4d64e5da6da --- /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 00000000000..9f3a8585c16 --- /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 00000000000..ad9e56f8010 --- /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 00000000000..b0e1a165ff5 --- /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 00000000000..b9a638d2501 --- /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 00000000000..926d6668ec8 --- /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 00000000000..a2aa0d1d4bd --- /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 00000000000..bccddbf0432 --- /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 00000000000..439bd8a9e80 --- /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/a-dhfina.ads b/gcc/ada/libgnat/a-dhfina.ads similarity index 100% rename from gcc/ada/a-dhfina.ads rename to gcc/ada/libgnat/a-dhfina.ads diff --git a/gcc/ada/libgnat/a-diocst.adb b/gcc/ada/libgnat/a-diocst.adb new file mode 100644 index 00000000000..508563f412a --- /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 00000000000..d0adf4996e0 --- /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/a-direct.adb b/gcc/ada/libgnat/a-direct.adb similarity index 100% rename from gcc/ada/a-direct.adb rename to gcc/ada/libgnat/a-direct.adb diff --git a/gcc/ada/libgnat/a-direct.ads b/gcc/ada/libgnat/a-direct.ads new file mode 100644 index 00000000000..d338ade4e11 --- /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/a-direio.adb b/gcc/ada/libgnat/a-direio.adb similarity index 100% rename from gcc/ada/a-direio.adb rename to gcc/ada/libgnat/a-direio.adb diff --git a/gcc/ada/libgnat/a-direio.ads b/gcc/ada/libgnat/a-direio.ads new file mode 100644 index 00000000000..96ed11d97fc --- /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/a-dirval-mingw.adb b/gcc/ada/libgnat/a-dirval-mingw.adb similarity index 100% rename from gcc/ada/a-dirval-mingw.adb rename to gcc/ada/libgnat/a-dirval-mingw.adb diff --git a/gcc/ada/libgnat/a-dirval.adb b/gcc/ada/libgnat/a-dirval.adb new file mode 100644 index 00000000000..25466a57e0d --- /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 00000000000..a5deca67da3 --- /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 00000000000..2a9f8b91df9 --- /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 00000000000..f4281245a5c --- /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 00000000000..1b03a186468 --- /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 00000000000..8839e8fbe74 --- /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 00000000000..0cdcb997a0f --- /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 00000000000..c4141741496 --- /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/a-envvar.ads b/gcc/ada/libgnat/a-envvar.ads similarity index 100% rename from gcc/ada/a-envvar.ads rename to gcc/ada/libgnat/a-envvar.ads diff --git a/gcc/ada/libgnat/a-excach.adb b/gcc/ada/libgnat/a-excach.adb new file mode 100644 index 00000000000..5cba070870f --- /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/a-except.adb b/gcc/ada/libgnat/a-except.adb similarity index 100% rename from gcc/ada/a-except.adb rename to gcc/ada/libgnat/a-except.adb diff --git a/gcc/ada/a-except.ads b/gcc/ada/libgnat/a-except.ads similarity index 100% rename from gcc/ada/a-except.ads rename to gcc/ada/libgnat/a-except.ads diff --git a/gcc/ada/libgnat/a-excpol-abort.adb b/gcc/ada/libgnat/a-excpol-abort.adb new file mode 100644 index 00000000000..8ed2e667197 --- /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 00000000000..3568e9c3add --- /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 00000000000..cbe30e544be --- /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 00000000000..f395348abc7 --- /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 00000000000..796648729a4 --- /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 00000000000..339582a771e --- /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 00000000000..d59c148ef2d --- /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 00000000000..898e4cb5f2d --- /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 00000000000..36690f96256 --- /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 00000000000..6f001db83ba --- /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/a-flteio.ads b/gcc/ada/libgnat/a-flteio.ads similarity index 100% rename from gcc/ada/a-flteio.ads rename to gcc/ada/libgnat/a-flteio.ads diff --git a/gcc/ada/a-fwteio.ads b/gcc/ada/libgnat/a-fwteio.ads similarity index 100% rename from gcc/ada/a-fwteio.ads rename to gcc/ada/libgnat/a-fwteio.ads diff --git a/gcc/ada/a-fzteio.ads b/gcc/ada/libgnat/a-fzteio.ads similarity index 100% rename from gcc/ada/a-fzteio.ads rename to gcc/ada/libgnat/a-fzteio.ads diff --git a/gcc/ada/a-inteio.ads b/gcc/ada/libgnat/a-inteio.ads similarity index 100% rename from gcc/ada/a-inteio.ads rename to gcc/ada/libgnat/a-inteio.ads diff --git a/gcc/ada/a-ioexce.ads b/gcc/ada/libgnat/a-ioexce.ads similarity index 100% rename from gcc/ada/a-ioexce.ads rename to gcc/ada/libgnat/a-ioexce.ads diff --git a/gcc/ada/a-iteint.ads b/gcc/ada/libgnat/a-iteint.ads similarity index 100% rename from gcc/ada/a-iteint.ads rename to gcc/ada/libgnat/a-iteint.ads diff --git a/gcc/ada/a-iwteio.ads b/gcc/ada/libgnat/a-iwteio.ads similarity index 100% rename from gcc/ada/a-iwteio.ads rename to gcc/ada/libgnat/a-iwteio.ads diff --git a/gcc/ada/a-izteio.ads b/gcc/ada/libgnat/a-izteio.ads similarity index 100% rename from gcc/ada/a-izteio.ads rename to gcc/ada/libgnat/a-izteio.ads diff --git a/gcc/ada/a-lcteio.ads b/gcc/ada/libgnat/a-lcteio.ads similarity index 100% rename from gcc/ada/a-lcteio.ads rename to gcc/ada/libgnat/a-lcteio.ads diff --git a/gcc/ada/a-lfteio.ads b/gcc/ada/libgnat/a-lfteio.ads similarity index 100% rename from gcc/ada/a-lfteio.ads rename to gcc/ada/libgnat/a-lfteio.ads diff --git a/gcc/ada/a-lfwtio.ads b/gcc/ada/libgnat/a-lfwtio.ads similarity index 100% rename from gcc/ada/a-lfwtio.ads rename to gcc/ada/libgnat/a-lfwtio.ads diff --git a/gcc/ada/a-lfztio.ads b/gcc/ada/libgnat/a-lfztio.ads similarity index 100% rename from gcc/ada/a-lfztio.ads rename to gcc/ada/libgnat/a-lfztio.ads diff --git a/gcc/ada/a-liteio.ads b/gcc/ada/libgnat/a-liteio.ads similarity index 100% rename from gcc/ada/a-liteio.ads rename to gcc/ada/libgnat/a-liteio.ads diff --git a/gcc/ada/a-liwtio.ads b/gcc/ada/libgnat/a-liwtio.ads similarity index 100% rename from gcc/ada/a-liwtio.ads rename to gcc/ada/libgnat/a-liwtio.ads diff --git a/gcc/ada/a-liztio.ads b/gcc/ada/libgnat/a-liztio.ads similarity index 100% rename from gcc/ada/a-liztio.ads rename to gcc/ada/libgnat/a-liztio.ads diff --git a/gcc/ada/a-llctio.ads b/gcc/ada/libgnat/a-llctio.ads similarity index 100% rename from gcc/ada/a-llctio.ads rename to gcc/ada/libgnat/a-llctio.ads diff --git a/gcc/ada/a-llftio.ads b/gcc/ada/libgnat/a-llftio.ads similarity index 100% rename from gcc/ada/a-llftio.ads rename to gcc/ada/libgnat/a-llftio.ads diff --git a/gcc/ada/a-llfwti.ads b/gcc/ada/libgnat/a-llfwti.ads similarity index 100% rename from gcc/ada/a-llfwti.ads rename to gcc/ada/libgnat/a-llfwti.ads diff --git a/gcc/ada/a-llfzti.ads b/gcc/ada/libgnat/a-llfzti.ads similarity index 100% rename from gcc/ada/a-llfzti.ads rename to gcc/ada/libgnat/a-llfzti.ads diff --git a/gcc/ada/a-llitio.ads b/gcc/ada/libgnat/a-llitio.ads similarity index 100% rename from gcc/ada/a-llitio.ads rename to gcc/ada/libgnat/a-llitio.ads diff --git a/gcc/ada/a-lliwti.ads b/gcc/ada/libgnat/a-lliwti.ads similarity index 100% rename from gcc/ada/a-lliwti.ads rename to gcc/ada/libgnat/a-lliwti.ads diff --git a/gcc/ada/a-llizti.ads b/gcc/ada/libgnat/a-llizti.ads similarity index 100% rename from gcc/ada/a-llizti.ads rename to gcc/ada/libgnat/a-llizti.ads diff --git a/gcc/ada/libgnat/a-locale.adb b/gcc/ada/libgnat/a-locale.adb new file mode 100644 index 00000000000..9c2f3142c52 --- /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/a-locale.ads b/gcc/ada/libgnat/a-locale.ads similarity index 100% rename from gcc/ada/a-locale.ads rename to gcc/ada/libgnat/a-locale.ads diff --git a/gcc/ada/a-ncelfu.ads b/gcc/ada/libgnat/a-ncelfu.ads similarity index 100% rename from gcc/ada/a-ncelfu.ads rename to gcc/ada/libgnat/a-ncelfu.ads diff --git a/gcc/ada/libgnat/a-ngcefu.adb b/gcc/ada/libgnat/a-ngcefu.adb new file mode 100644 index 00000000000..3f3973fbdc7 --- /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/a-ngcefu.ads b/gcc/ada/libgnat/a-ngcefu.ads similarity index 100% rename from gcc/ada/a-ngcefu.ads rename to gcc/ada/libgnat/a-ngcefu.ads diff --git a/gcc/ada/libgnat/a-ngcoar.adb b/gcc/ada/libgnat/a-ngcoar.adb new file mode 100644 index 00000000000..cf01dcdef80 --- /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/a-ngcoar.ads b/gcc/ada/libgnat/a-ngcoar.ads similarity index 100% rename from gcc/ada/a-ngcoar.ads rename to gcc/ada/libgnat/a-ngcoar.ads diff --git a/gcc/ada/libgnat/a-ngcoty.adb b/gcc/ada/libgnat/a-ngcoty.adb new file mode 100644 index 00000000000..684fdebdcb8 --- /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 00000000000..bc3ff577ed7 --- /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 00000000000..87c88c3fd0e --- /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/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads similarity index 100% rename from gcc/ada/a-ngelfu.ads rename to gcc/ada/libgnat/a-ngelfu.ads diff --git a/gcc/ada/libgnat/a-ngrear.adb b/gcc/ada/libgnat/a-ngrear.adb new file mode 100644 index 00000000000..258f3cb4d33 --- /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 00000000000..0602d3e5e6c --- /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/a-nlcefu.ads b/gcc/ada/libgnat/a-nlcefu.ads similarity index 100% rename from gcc/ada/a-nlcefu.ads rename to gcc/ada/libgnat/a-nlcefu.ads diff --git a/gcc/ada/a-nlcoar.ads b/gcc/ada/libgnat/a-nlcoar.ads similarity index 100% rename from gcc/ada/a-nlcoar.ads rename to gcc/ada/libgnat/a-nlcoar.ads diff --git a/gcc/ada/a-nlcoty.ads b/gcc/ada/libgnat/a-nlcoty.ads similarity index 100% rename from gcc/ada/a-nlcoty.ads rename to gcc/ada/libgnat/a-nlcoty.ads diff --git a/gcc/ada/a-nlelfu.ads b/gcc/ada/libgnat/a-nlelfu.ads similarity index 100% rename from gcc/ada/a-nlelfu.ads rename to gcc/ada/libgnat/a-nlelfu.ads diff --git a/gcc/ada/a-nllcar.ads b/gcc/ada/libgnat/a-nllcar.ads similarity index 100% rename from gcc/ada/a-nllcar.ads rename to gcc/ada/libgnat/a-nllcar.ads diff --git a/gcc/ada/a-nllcef.ads b/gcc/ada/libgnat/a-nllcef.ads similarity index 100% rename from gcc/ada/a-nllcef.ads rename to gcc/ada/libgnat/a-nllcef.ads diff --git a/gcc/ada/a-nllcty.ads b/gcc/ada/libgnat/a-nllcty.ads similarity index 100% rename from gcc/ada/a-nllcty.ads rename to gcc/ada/libgnat/a-nllcty.ads diff --git a/gcc/ada/a-nllefu.ads b/gcc/ada/libgnat/a-nllefu.ads similarity index 100% rename from gcc/ada/a-nllefu.ads rename to gcc/ada/libgnat/a-nllefu.ads diff --git a/gcc/ada/a-nllrar.ads b/gcc/ada/libgnat/a-nllrar.ads similarity index 100% rename from gcc/ada/a-nllrar.ads rename to gcc/ada/libgnat/a-nllrar.ads diff --git a/gcc/ada/a-nlrear.ads b/gcc/ada/libgnat/a-nlrear.ads similarity index 100% rename from gcc/ada/a-nlrear.ads rename to gcc/ada/libgnat/a-nlrear.ads diff --git a/gcc/ada/a-nscefu.ads b/gcc/ada/libgnat/a-nscefu.ads similarity index 100% rename from gcc/ada/a-nscefu.ads rename to gcc/ada/libgnat/a-nscefu.ads diff --git a/gcc/ada/a-nscoty.ads b/gcc/ada/libgnat/a-nscoty.ads similarity index 100% rename from gcc/ada/a-nscoty.ads rename to gcc/ada/libgnat/a-nscoty.ads diff --git a/gcc/ada/a-nselfu.ads b/gcc/ada/libgnat/a-nselfu.ads similarity index 100% rename from gcc/ada/a-nselfu.ads rename to gcc/ada/libgnat/a-nselfu.ads diff --git a/gcc/ada/a-nucoar.ads b/gcc/ada/libgnat/a-nucoar.ads similarity index 100% rename from gcc/ada/a-nucoar.ads rename to gcc/ada/libgnat/a-nucoar.ads diff --git a/gcc/ada/a-nucoty.ads b/gcc/ada/libgnat/a-nucoty.ads similarity index 100% rename from gcc/ada/a-nucoty.ads rename to gcc/ada/libgnat/a-nucoty.ads diff --git a/gcc/ada/libgnat/a-nudira.adb b/gcc/ada/libgnat/a-nudira.adb new file mode 100644 index 00000000000..2f065f596a4 --- /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 00000000000..b957f478df9 --- /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/a-nuelfu.ads b/gcc/ada/libgnat/a-nuelfu.ads similarity index 100% rename from gcc/ada/a-nuelfu.ads rename to gcc/ada/libgnat/a-nuelfu.ads diff --git a/gcc/ada/libgnat/a-nuflra.adb b/gcc/ada/libgnat/a-nuflra.adb new file mode 100644 index 00000000000..eb58a7b7aa3 --- /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 00000000000..d1eedbcca02 --- /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 00000000000..88e9e7c2a2d --- /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 00000000000..5767f4d563c --- /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 00000000000..e6adf210597 --- /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 00000000000..31f57c071e2 --- /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 00000000000..303b7293c2c --- /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 00000000000..2002ccdbca2 --- /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 00000000000..50f6d0b9e13 --- /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/a-numeri.ads b/gcc/ada/libgnat/a-numeri.ads similarity index 100% rename from gcc/ada/a-numeri.ads rename to gcc/ada/libgnat/a-numeri.ads diff --git a/gcc/ada/a-nurear.ads b/gcc/ada/libgnat/a-nurear.ads similarity index 100% rename from gcc/ada/a-nurear.ads rename to gcc/ada/libgnat/a-nurear.ads diff --git a/gcc/ada/libgnat/a-rbtgbk.adb b/gcc/ada/libgnat/a-rbtgbk.adb new file mode 100644 index 00000000000..2488e21ad91 --- /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 00000000000..e91bffd1869 --- /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 00000000000..e5c1b64932c --- /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 00000000000..e5e313ebf08 --- /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 00000000000..8f7600c27bf --- /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 00000000000..80617f28ce2 --- /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 00000000000..381874c4201 --- /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 00000000000..d510864fdb7 --- /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 00000000000..8456faef7fc --- /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 00000000000..323e5427922 --- /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 00000000000..cc1e2425b62 --- /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 00000000000..97429f3503e --- /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/a-scteio.ads b/gcc/ada/libgnat/a-scteio.ads similarity index 100% rename from gcc/ada/a-scteio.ads rename to gcc/ada/libgnat/a-scteio.ads diff --git a/gcc/ada/libgnat/a-secain.adb b/gcc/ada/libgnat/a-secain.adb new file mode 100644 index 00000000000..903a7603d84 --- /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 00000000000..b8b3f898602 --- /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 00000000000..770e75a363f --- /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 00000000000..6d2d568c5d0 --- /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 00000000000..d2df2ea0485 --- /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 00000000000..03f3c2c07dd --- /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 00000000000..69ea2979a3b --- /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/a-sfteio.ads b/gcc/ada/libgnat/a-sfteio.ads similarity index 100% rename from gcc/ada/a-sfteio.ads rename to gcc/ada/libgnat/a-sfteio.ads diff --git a/gcc/ada/a-sfwtio.ads b/gcc/ada/libgnat/a-sfwtio.ads similarity index 100% rename from gcc/ada/a-sfwtio.ads rename to gcc/ada/libgnat/a-sfwtio.ads diff --git a/gcc/ada/a-sfztio.ads b/gcc/ada/libgnat/a-sfztio.ads similarity index 100% rename from gcc/ada/a-sfztio.ads rename to gcc/ada/libgnat/a-sfztio.ads diff --git a/gcc/ada/libgnat/a-shcain.adb b/gcc/ada/libgnat/a-shcain.adb new file mode 100644 index 00000000000..83fe21e7b57 --- /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 00000000000..266d8998ba1 --- /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 00000000000..5972f2dabdc --- /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 00000000000..bf9d135e626 --- /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/a-siteio.ads b/gcc/ada/libgnat/a-siteio.ads similarity index 100% rename from gcc/ada/a-siteio.ads rename to gcc/ada/libgnat/a-siteio.ads diff --git a/gcc/ada/a-siwtio.ads b/gcc/ada/libgnat/a-siwtio.ads similarity index 100% rename from gcc/ada/a-siwtio.ads rename to gcc/ada/libgnat/a-siwtio.ads diff --git a/gcc/ada/a-siztio.ads b/gcc/ada/libgnat/a-siztio.ads similarity index 100% rename from gcc/ada/a-siztio.ads rename to gcc/ada/libgnat/a-siztio.ads diff --git a/gcc/ada/libgnat/a-slcain.adb b/gcc/ada/libgnat/a-slcain.adb new file mode 100644 index 00000000000..2a896e362f1 --- /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 00000000000..e8848737eef --- /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/a-ssicst.adb b/gcc/ada/libgnat/a-ssicst.adb similarity index 100% rename from gcc/ada/a-ssicst.adb rename to gcc/ada/libgnat/a-ssicst.adb diff --git a/gcc/ada/libgnat/a-ssicst.ads b/gcc/ada/libgnat/a-ssicst.ads new file mode 100644 index 00000000000..ceadadf7670 --- /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/a-ssitio.ads b/gcc/ada/libgnat/a-ssitio.ads similarity index 100% rename from gcc/ada/a-ssitio.ads rename to gcc/ada/libgnat/a-ssitio.ads diff --git a/gcc/ada/a-ssiwti.ads b/gcc/ada/libgnat/a-ssiwti.ads similarity index 100% rename from gcc/ada/a-ssiwti.ads rename to gcc/ada/libgnat/a-ssiwti.ads diff --git a/gcc/ada/a-ssizti.ads b/gcc/ada/libgnat/a-ssizti.ads similarity index 100% rename from gcc/ada/a-ssizti.ads rename to gcc/ada/libgnat/a-ssizti.ads diff --git a/gcc/ada/libgnat/a-stboha.adb b/gcc/ada/libgnat/a-stboha.adb new file mode 100644 index 00000000000..67dd87a14fe --- /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/a-stboha.ads b/gcc/ada/libgnat/a-stboha.ads similarity index 100% rename from gcc/ada/a-stboha.ads rename to gcc/ada/libgnat/a-stboha.ads diff --git a/gcc/ada/a-stfiha.ads b/gcc/ada/libgnat/a-stfiha.ads similarity index 100% rename from gcc/ada/a-stfiha.ads rename to gcc/ada/libgnat/a-stfiha.ads diff --git a/gcc/ada/libgnat/a-stmaco.ads b/gcc/ada/libgnat/a-stmaco.ads new file mode 100644 index 00000000000..aed9abc5ad3 --- /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 00000000000..0cea9d0b06d --- /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/a-storio.ads b/gcc/ada/libgnat/a-storio.ads similarity index 100% rename from gcc/ada/a-storio.ads rename to gcc/ada/libgnat/a-storio.ads diff --git a/gcc/ada/libgnat/a-strbou.adb b/gcc/ada/libgnat/a-strbou.adb new file mode 100644 index 00000000000..da1605bff60 --- /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 00000000000..4138a97203a --- /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 00000000000..21e26d40cc7 --- /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/a-stream.ads b/gcc/ada/libgnat/a-stream.ads similarity index 100% rename from gcc/ada/a-stream.ads rename to gcc/ada/libgnat/a-stream.ads diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb similarity index 100% rename from gcc/ada/a-strfix.adb rename to gcc/ada/libgnat/a-strfix.adb diff --git a/gcc/ada/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads similarity index 100% rename from gcc/ada/a-strfix.ads rename to gcc/ada/libgnat/a-strfix.ads diff --git a/gcc/ada/libgnat/a-strhas.adb b/gcc/ada/libgnat/a-strhas.adb new file mode 100644 index 00000000000..bf91af75393 --- /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/a-strhas.ads b/gcc/ada/libgnat/a-strhas.ads similarity index 100% rename from gcc/ada/a-strhas.ads rename to gcc/ada/libgnat/a-strhas.ads diff --git a/gcc/ada/a-string.ads b/gcc/ada/libgnat/a-string.ads similarity index 100% rename from gcc/ada/a-string.ads rename to gcc/ada/libgnat/a-string.ads diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb new file mode 100644 index 00000000000..a98556b6dc3 --- /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 00000000000..6e65c0f2430 --- /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 00000000000..9b9fa4660fb --- /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/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads similarity index 100% rename from gcc/ada/a-strsea.ads rename to gcc/ada/libgnat/a-strsea.ads diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb new file mode 100644 index 00000000000..8cca8eb46d7 --- /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 00000000000..950a68aec3b --- /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 00000000000..4347c065ea7 --- /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 00000000000..3efa51c8a32 --- /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 00000000000..808e26ad29f --- /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 00000000000..a06d1fc9c06 --- /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 00000000000..ddc78c9183a --- /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 00000000000..efcb5fc6925 --- /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 00000000000..583deedeef1 --- /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 00000000000..a2501ac29f8 --- /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 00000000000..90b7505e177 --- /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 00000000000..a8626fca984 --- /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/a-stunha.ads b/gcc/ada/libgnat/a-stunha.ads similarity index 100% rename from gcc/ada/a-stunha.ads rename to gcc/ada/libgnat/a-stunha.ads diff --git a/gcc/ada/libgnat/a-stuten.adb b/gcc/ada/libgnat/a-stuten.adb new file mode 100644 index 00000000000..02a11155d30 --- /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/a-stuten.ads b/gcc/ada/libgnat/a-stuten.ads similarity index 100% rename from gcc/ada/a-stuten.ads rename to gcc/ada/libgnat/a-stuten.ads diff --git a/gcc/ada/libgnat/a-stwibo.adb b/gcc/ada/libgnat/a-stwibo.adb new file mode 100644 index 00000000000..0a68d8c0b0c --- /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 00000000000..5efce28ba9b --- /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 00000000000..6a7c2fabc76 --- /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/a-stwifi.ads b/gcc/ada/libgnat/a-stwifi.ads similarity index 100% rename from gcc/ada/a-stwifi.ads rename to gcc/ada/libgnat/a-stwifi.ads diff --git a/gcc/ada/libgnat/a-stwiha.adb b/gcc/ada/libgnat/a-stwiha.adb new file mode 100644 index 00000000000..cd1517ac80c --- /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/a-stwiha.ads b/gcc/ada/libgnat/a-stwiha.ads similarity index 100% rename from gcc/ada/a-stwiha.ads rename to gcc/ada/libgnat/a-stwiha.ads diff --git a/gcc/ada/libgnat/a-stwima.adb b/gcc/ada/libgnat/a-stwima.adb new file mode 100644 index 00000000000..dfdddfefe40 --- /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 00000000000..cbbb65eb1b1 --- /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 00000000000..8c2d7430410 --- /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/a-stwise.ads b/gcc/ada/libgnat/a-stwise.ads similarity index 100% rename from gcc/ada/a-stwise.ads rename to gcc/ada/libgnat/a-stwise.ads diff --git a/gcc/ada/libgnat/a-stwisu.adb b/gcc/ada/libgnat/a-stwisu.adb new file mode 100644 index 00000000000..b09347687f1 --- /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 00000000000..e14d7dca41b --- /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 00000000000..479e66abffe --- /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 00000000000..a913df441c3 --- /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 00000000000..85bc494ff9c --- /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 00000000000..3b232f23221 --- /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 00000000000..f7d566a7154 --- /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 00000000000..fb413dc2c5c --- /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 00000000000..736920887b9 --- /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/a-stzfix.ads b/gcc/ada/libgnat/a-stzfix.ads similarity index 100% rename from gcc/ada/a-stzfix.ads rename to gcc/ada/libgnat/a-stzfix.ads diff --git a/gcc/ada/libgnat/a-stzhas.adb b/gcc/ada/libgnat/a-stzhas.adb new file mode 100644 index 00000000000..9856476b7fb --- /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/a-stzhas.ads b/gcc/ada/libgnat/a-stzhas.ads similarity index 100% rename from gcc/ada/a-stzhas.ads rename to gcc/ada/libgnat/a-stzhas.ads diff --git a/gcc/ada/libgnat/a-stzmap.adb b/gcc/ada/libgnat/a-stzmap.adb new file mode 100644 index 00000000000..e70898d74ca --- /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 00000000000..1b0c2310cb3 --- /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 00000000000..b5a62e7557c --- /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/a-stzsea.ads b/gcc/ada/libgnat/a-stzsea.ads similarity index 100% rename from gcc/ada/a-stzsea.ads rename to gcc/ada/libgnat/a-stzsea.ads diff --git a/gcc/ada/libgnat/a-stzsup.adb b/gcc/ada/libgnat/a-stzsup.adb new file mode 100644 index 00000000000..abcb97be72f --- /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 00000000000..a3bc7f508fe --- /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 00000000000..e8b23729868 --- /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 00000000000..f1ad9231c0b --- /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 00000000000..25c3b29ac2e --- /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 00000000000..9b9cf69be65 --- /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 00000000000..0ff49085f44 --- /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 00000000000..996f0e3bc18 --- /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 00000000000..1e288f5bedb --- /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/a-suenco.ads b/gcc/ada/libgnat/a-suenco.ads similarity index 100% rename from gcc/ada/a-suenco.ads rename to gcc/ada/libgnat/a-suenco.ads diff --git a/gcc/ada/libgnat/a-suenst.adb b/gcc/ada/libgnat/a-suenst.adb new file mode 100644 index 00000000000..44639bd99e3 --- /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/a-suenst.ads b/gcc/ada/libgnat/a-suenst.ads similarity index 100% rename from gcc/ada/a-suenst.ads rename to gcc/ada/libgnat/a-suenst.ads diff --git a/gcc/ada/libgnat/a-suewst.adb b/gcc/ada/libgnat/a-suewst.adb new file mode 100644 index 00000000000..5ee896aff5c --- /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/a-suewst.ads b/gcc/ada/libgnat/a-suewst.ads similarity index 100% rename from gcc/ada/a-suewst.ads rename to gcc/ada/libgnat/a-suewst.ads diff --git a/gcc/ada/libgnat/a-suezst.adb b/gcc/ada/libgnat/a-suezst.adb new file mode 100644 index 00000000000..4528bdd8b71 --- /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/a-suezst.ads b/gcc/ada/libgnat/a-suezst.ads similarity index 100% rename from gcc/ada/a-suezst.ads rename to gcc/ada/libgnat/a-suezst.ads diff --git a/gcc/ada/libgnat/a-suhcin.adb b/gcc/ada/libgnat/a-suhcin.adb new file mode 100644 index 00000000000..fa94635f154 --- /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 00000000000..3a05d8edb44 --- /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 00000000000..93c785e1205 --- /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 00000000000..0706c071dbb --- /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 00000000000..13d537d3874 --- /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 00000000000..7c48bc5a738 --- /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 00000000000..7e925383778 --- /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 00000000000..1addc2ee552 --- /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/a-swbwha.ads b/gcc/ada/libgnat/a-swbwha.ads similarity index 100% rename from gcc/ada/a-swbwha.ads rename to gcc/ada/libgnat/a-swbwha.ads diff --git a/gcc/ada/a-swfwha.ads b/gcc/ada/libgnat/a-swfwha.ads similarity index 100% rename from gcc/ada/a-swfwha.ads rename to gcc/ada/libgnat/a-swfwha.ads diff --git a/gcc/ada/libgnat/a-swmwco.ads b/gcc/ada/libgnat/a-swmwco.ads new file mode 100644 index 00000000000..e29f1d10c4b --- /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 00000000000..c65f7d01e44 --- /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 00000000000..88c2a242df7 --- /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 00000000000..b4e8ddb4704 --- /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 00000000000..8333ccd1d6e --- /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/a-swuwha.ads b/gcc/ada/libgnat/a-swuwha.ads similarity index 100% rename from gcc/ada/a-swuwha.ads rename to gcc/ada/libgnat/a-swuwha.ads diff --git a/gcc/ada/libgnat/a-swuwti-shared.adb b/gcc/ada/libgnat/a-swuwti-shared.adb new file mode 100644 index 00000000000..1b1c127c67a --- /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 00000000000..b849c680b57 --- /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 00000000000..6c6249cf262 --- /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 00000000000..d0ade2193da --- /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/a-szbzha.ads b/gcc/ada/libgnat/a-szbzha.ads similarity index 100% rename from gcc/ada/a-szbzha.ads rename to gcc/ada/libgnat/a-szbzha.ads diff --git a/gcc/ada/a-szfzha.ads b/gcc/ada/libgnat/a-szfzha.ads similarity index 100% rename from gcc/ada/a-szfzha.ads rename to gcc/ada/libgnat/a-szfzha.ads diff --git a/gcc/ada/libgnat/a-szmzco.ads b/gcc/ada/libgnat/a-szmzco.ads new file mode 100644 index 00000000000..b8208e09d06 --- /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 00000000000..51737e04f23 --- /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 00000000000..bfbdab0c1a4 --- /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 00000000000..f28d29d17f2 --- /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 00000000000..df876715f35 --- /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/a-szuzha.ads b/gcc/ada/libgnat/a-szuzha.ads similarity index 100% rename from gcc/ada/a-szuzha.ads rename to gcc/ada/libgnat/a-szuzha.ads diff --git a/gcc/ada/libgnat/a-szuzti-shared.adb b/gcc/ada/libgnat/a-szuzti-shared.adb new file mode 100644 index 00000000000..d8807aff83f --- /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 00000000000..f1e9f029170 --- /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 00000000000..ec97aa989e0 --- /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/a-tags.adb b/gcc/ada/libgnat/a-tags.adb similarity index 100% rename from gcc/ada/a-tags.adb rename to gcc/ada/libgnat/a-tags.adb diff --git a/gcc/ada/a-tags.ads b/gcc/ada/libgnat/a-tags.ads similarity index 100% rename from gcc/ada/a-tags.ads rename to gcc/ada/libgnat/a-tags.ads diff --git a/gcc/ada/libgnat/a-teioed.adb b/gcc/ada/libgnat/a-teioed.adb new file mode 100644 index 00000000000..93e69f694e9 --- /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 00000000000..d22015f492c --- /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/a-textio.adb b/gcc/ada/libgnat/a-textio.adb similarity index 100% rename from gcc/ada/a-textio.adb rename to gcc/ada/libgnat/a-textio.adb diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads new file mode 100644 index 00000000000..5c8589231b1 --- /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/a-tgdico.ads b/gcc/ada/libgnat/a-tgdico.ads similarity index 100% rename from gcc/ada/a-tgdico.ads rename to gcc/ada/libgnat/a-tgdico.ads diff --git a/gcc/ada/libgnat/a-tiboio.adb b/gcc/ada/libgnat/a-tiboio.adb new file mode 100644 index 00000000000..f6980614232 --- /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/a-tiboio.ads b/gcc/ada/libgnat/a-tiboio.ads similarity index 100% rename from gcc/ada/a-tiboio.ads rename to gcc/ada/libgnat/a-tiboio.ads diff --git a/gcc/ada/libgnat/a-ticoau.adb b/gcc/ada/libgnat/a-ticoau.adb new file mode 100644 index 00000000000..5eed39200b8 --- /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 00000000000..8ffe40a4361 --- /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 00000000000..558784533de --- /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 00000000000..251ad89c4ce --- /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 00000000000..5f124c0afae --- /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 00000000000..e5f42ce0f31 --- /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 00000000000..4c4d6d0415a --- /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 00000000000..3234dadc867 --- /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 00000000000..729e5169fc2 --- /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 00000000000..e8cce26090c --- /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 00000000000..0eda96cdbb1 --- /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/a-tienio.ads b/gcc/ada/libgnat/a-tienio.ads similarity index 100% rename from gcc/ada/a-tienio.ads rename to gcc/ada/libgnat/a-tienio.ads diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb new file mode 100644 index 00000000000..c0130123ca3 --- /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/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads similarity index 100% rename from gcc/ada/a-tifiio.ads rename to gcc/ada/libgnat/a-tifiio.ads diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb new file mode 100644 index 00000000000..2d0d9001272 --- /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 00000000000..81830efc032 --- /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 00000000000..a6f7d93a024 --- /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 00000000000..78be75f9c5e --- /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 00000000000..34dac8bf5e7 --- /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 00000000000..0b99ff7fd4b --- /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/a-tigeli.adb b/gcc/ada/libgnat/a-tigeli.adb similarity index 100% rename from gcc/ada/a-tigeli.adb rename to gcc/ada/libgnat/a-tigeli.adb diff --git a/gcc/ada/libgnat/a-tiinau.adb b/gcc/ada/libgnat/a-tiinau.adb new file mode 100644 index 00000000000..cf729b6c28c --- /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 00000000000..d644e4a2838 --- /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 00000000000..b93dc6ae41a --- /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 00000000000..70636310793 --- /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 00000000000..6322efc96b9 --- /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 00000000000..da5556fa959 --- /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 00000000000..3e0430d6092 --- /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 00000000000..d1ba92fdf4d --- /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 00000000000..ac7d3451bdc --- /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 00000000000..b0c0229faf2 --- /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 00000000000..443bbe49bb9 --- /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 00000000000..1e436af16d7 --- /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 00000000000..209350007c4 --- /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/a-titest.ads b/gcc/ada/libgnat/a-titest.ads similarity index 100% rename from gcc/ada/a-titest.ads rename to gcc/ada/libgnat/a-titest.ads diff --git a/gcc/ada/a-tiunio.ads b/gcc/ada/libgnat/a-tiunio.ads similarity index 100% rename from gcc/ada/a-tiunio.ads rename to gcc/ada/libgnat/a-tiunio.ads diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/libgnat/a-unccon.ads similarity index 100% rename from gcc/ada/a-unccon.ads rename to gcc/ada/libgnat/a-unccon.ads diff --git a/gcc/ada/a-uncdea.ads b/gcc/ada/libgnat/a-uncdea.ads similarity index 100% rename from gcc/ada/a-uncdea.ads rename to gcc/ada/libgnat/a-uncdea.ads diff --git a/gcc/ada/libgnat/a-undesu.adb b/gcc/ada/libgnat/a-undesu.adb new file mode 100644 index 00000000000..4fb4c17ccc2 --- /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/a-undesu.ads b/gcc/ada/libgnat/a-undesu.ads similarity index 100% rename from gcc/ada/a-undesu.ads rename to gcc/ada/libgnat/a-undesu.ads diff --git a/gcc/ada/libgnat/a-wichha.adb b/gcc/ada/libgnat/a-wichha.adb new file mode 100644 index 00000000000..cd124f05697 --- /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/a-wichha.ads b/gcc/ada/libgnat/a-wichha.ads similarity index 100% rename from gcc/ada/a-wichha.ads rename to gcc/ada/libgnat/a-wichha.ads diff --git a/gcc/ada/libgnat/a-wichun.adb b/gcc/ada/libgnat/a-wichun.adb new file mode 100644 index 00000000000..a58ccd339a6 --- /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 00000000000..a014402074f --- /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/a-widcha.ads b/gcc/ada/libgnat/a-widcha.ads similarity index 100% rename from gcc/ada/a-widcha.ads rename to gcc/ada/libgnat/a-widcha.ads diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/libgnat/a-witeio.adb similarity index 100% rename from gcc/ada/a-witeio.adb rename to gcc/ada/libgnat/a-witeio.adb diff --git a/gcc/ada/libgnat/a-witeio.ads b/gcc/ada/libgnat/a-witeio.ads new file mode 100644 index 00000000000..bbf35eb8563 --- /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 00000000000..b9df99ae1d0 --- /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 00000000000..13ed65fcc91 --- /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 00000000000..ca14dcb2237 --- /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 00000000000..23bd6ceb000 --- /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 00000000000..117b43ee9bd --- /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/a-wtcoio.ads b/gcc/ada/libgnat/a-wtcoio.ads similarity index 100% rename from gcc/ada/a-wtcoio.ads rename to gcc/ada/libgnat/a-wtcoio.ads diff --git a/gcc/ada/libgnat/a-wtcstr.adb b/gcc/ada/libgnat/a-wtcstr.adb new file mode 100644 index 00000000000..8c4544df620 --- /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 00000000000..898b0288584 --- /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 00000000000..9aea8adeaff --- /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 00000000000..c99f0e08f2d --- /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/a-wtdeio.adb b/gcc/ada/libgnat/a-wtdeio.adb similarity index 100% rename from gcc/ada/a-wtdeio.adb rename to gcc/ada/libgnat/a-wtdeio.adb diff --git a/gcc/ada/a-wtdeio.ads b/gcc/ada/libgnat/a-wtdeio.ads similarity index 100% rename from gcc/ada/a-wtdeio.ads rename to gcc/ada/libgnat/a-wtdeio.ads diff --git a/gcc/ada/libgnat/a-wtedit.adb b/gcc/ada/libgnat/a-wtedit.adb new file mode 100644 index 00000000000..4690b21064b --- /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 00000000000..1f2c1b101fd --- /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 00000000000..3c880360105 --- /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 00000000000..a466aaa9732 --- /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 00000000000..ef80a2efba7 --- /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/a-wtenio.ads b/gcc/ada/libgnat/a-wtenio.ads similarity index 100% rename from gcc/ada/a-wtenio.ads rename to gcc/ada/libgnat/a-wtenio.ads diff --git a/gcc/ada/libgnat/a-wtfiio.adb b/gcc/ada/libgnat/a-wtfiio.adb new file mode 100644 index 00000000000..fc41c45aea6 --- /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/a-wtfiio.ads b/gcc/ada/libgnat/a-wtfiio.ads similarity index 100% rename from gcc/ada/a-wtfiio.ads rename to gcc/ada/libgnat/a-wtfiio.ads diff --git a/gcc/ada/libgnat/a-wtflau.adb b/gcc/ada/libgnat/a-wtflau.adb new file mode 100644 index 00000000000..daf45833e86 --- /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 00000000000..6addc746b3c --- /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 00000000000..24bd570a363 --- /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/a-wtflio.ads b/gcc/ada/libgnat/a-wtflio.ads similarity index 100% rename from gcc/ada/a-wtflio.ads rename to gcc/ada/libgnat/a-wtflio.ads diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb new file mode 100644 index 00000000000..365e6d0236b --- /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 00000000000..432afc5b3f3 --- /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 00000000000..26d884faea6 --- /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 00000000000..c5e290225dc --- /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 00000000000..9cf4072f012 --- /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/a-wtinio.ads b/gcc/ada/libgnat/a-wtinio.ads similarity index 100% rename from gcc/ada/a-wtinio.ads rename to gcc/ada/libgnat/a-wtinio.ads diff --git a/gcc/ada/libgnat/a-wtmoau.adb b/gcc/ada/libgnat/a-wtmoau.adb new file mode 100644 index 00000000000..1e1f852fc03 --- /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 00000000000..2e9c3283585 --- /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 00000000000..509a2aa431b --- /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 00000000000..4fe7c6bb5e9 --- /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 00000000000..f966560c6f0 --- /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/a-wttest.ads b/gcc/ada/libgnat/a-wttest.ads similarity index 100% rename from gcc/ada/a-wttest.ads rename to gcc/ada/libgnat/a-wttest.ads diff --git a/gcc/ada/libgnat/a-wwboio.adb b/gcc/ada/libgnat/a-wwboio.adb new file mode 100644 index 00000000000..4b12984a77c --- /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/a-wwboio.ads b/gcc/ada/libgnat/a-wwboio.ads similarity index 100% rename from gcc/ada/a-wwboio.ads rename to gcc/ada/libgnat/a-wwboio.ads diff --git a/gcc/ada/a-wwunio.ads b/gcc/ada/libgnat/a-wwunio.ads similarity index 100% rename from gcc/ada/a-wwunio.ads rename to gcc/ada/libgnat/a-wwunio.ads diff --git a/gcc/ada/a-zchara.ads b/gcc/ada/libgnat/a-zchara.ads similarity index 100% rename from gcc/ada/a-zchara.ads rename to gcc/ada/libgnat/a-zchara.ads diff --git a/gcc/ada/libgnat/a-zchhan.adb b/gcc/ada/libgnat/a-zchhan.adb new file mode 100644 index 00000000000..fb9f8c834f1 --- /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/a-zchhan.ads b/gcc/ada/libgnat/a-zchhan.ads similarity index 100% rename from gcc/ada/a-zchhan.ads rename to gcc/ada/libgnat/a-zchhan.ads diff --git a/gcc/ada/libgnat/a-zchuni.adb b/gcc/ada/libgnat/a-zchuni.adb new file mode 100644 index 00000000000..4d8456c116c --- /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 00000000000..f05e6285987 --- /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 00000000000..66636d8ba9e --- /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 00000000000..aa79a0e0c4a --- /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 00000000000..c1870e44f0f --- /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/a-ztcoau.ads b/gcc/ada/libgnat/a-ztcoau.ads similarity index 100% rename from gcc/ada/a-ztcoau.ads rename to gcc/ada/libgnat/a-ztcoau.ads diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb new file mode 100644 index 00000000000..4498ae4517b --- /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/a-ztcoio.ads b/gcc/ada/libgnat/a-ztcoio.ads similarity index 100% rename from gcc/ada/a-ztcoio.ads rename to gcc/ada/libgnat/a-ztcoio.ads diff --git a/gcc/ada/libgnat/a-ztcstr.adb b/gcc/ada/libgnat/a-ztcstr.adb new file mode 100644 index 00000000000..835cc3391a9 --- /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 00000000000..7e2fc747ff8 --- /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 00000000000..67e18e71c55 --- /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 00000000000..3a21fb7c0b2 --- /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 00000000000..d2d32a5b1d8 --- /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/a-ztdeio.ads b/gcc/ada/libgnat/a-ztdeio.ads similarity index 100% rename from gcc/ada/a-ztdeio.ads rename to gcc/ada/libgnat/a-ztdeio.ads diff --git a/gcc/ada/libgnat/a-ztedit.adb b/gcc/ada/libgnat/a-ztedit.adb new file mode 100644 index 00000000000..896aeee7fbf --- /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 00000000000..be564dc7333 --- /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 00000000000..a4b160091d8 --- /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 00000000000..394ad204b35 --- /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 00000000000..ba26735aeca --- /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/a-ztenio.ads b/gcc/ada/libgnat/a-ztenio.ads similarity index 100% rename from gcc/ada/a-ztenio.ads rename to gcc/ada/libgnat/a-ztenio.ads diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/libgnat/a-ztexio.adb similarity index 100% rename from gcc/ada/a-ztexio.adb rename to gcc/ada/libgnat/a-ztexio.adb diff --git a/gcc/ada/libgnat/a-ztexio.ads b/gcc/ada/libgnat/a-ztexio.ads new file mode 100644 index 00000000000..730fc026723 --- /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 00000000000..ead61780b85 --- /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/a-ztfiio.ads b/gcc/ada/libgnat/a-ztfiio.ads similarity index 100% rename from gcc/ada/a-ztfiio.ads rename to gcc/ada/libgnat/a-ztfiio.ads diff --git a/gcc/ada/libgnat/a-ztflau.adb b/gcc/ada/libgnat/a-ztflau.adb new file mode 100644 index 00000000000..2b7db924f8c --- /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 00000000000..f6e8f7c3235 --- /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 00000000000..e19fef9ef0c --- /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/a-ztflio.ads b/gcc/ada/libgnat/a-ztflio.ads similarity index 100% rename from gcc/ada/a-ztflio.ads rename to gcc/ada/libgnat/a-ztflio.ads diff --git a/gcc/ada/libgnat/a-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb new file mode 100644 index 00000000000..55daa7468e1 --- /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 00000000000..c2388b18f3e --- /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 00000000000..6e5ba7274b0 --- /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 00000000000..b294eab149e --- /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 00000000000..197b99b31d5 --- /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/a-ztinio.ads b/gcc/ada/libgnat/a-ztinio.ads similarity index 100% rename from gcc/ada/a-ztinio.ads rename to gcc/ada/libgnat/a-ztinio.ads diff --git a/gcc/ada/libgnat/a-ztmoau.adb b/gcc/ada/libgnat/a-ztmoau.adb new file mode 100644 index 00000000000..6394b357f42 --- /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 00000000000..be387d2b27b --- /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 00000000000..f79d70195f6 --- /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/a-ztmoio.ads b/gcc/ada/libgnat/a-ztmoio.ads similarity index 100% rename from gcc/ada/a-ztmoio.ads rename to gcc/ada/libgnat/a-ztmoio.ads diff --git a/gcc/ada/libgnat/a-zttest.adb b/gcc/ada/libgnat/a-zttest.adb new file mode 100644 index 00000000000..db2a398b281 --- /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/a-zttest.ads b/gcc/ada/libgnat/a-zttest.ads similarity index 100% rename from gcc/ada/a-zttest.ads rename to gcc/ada/libgnat/a-zttest.ads diff --git a/gcc/ada/libgnat/a-zzboio.adb b/gcc/ada/libgnat/a-zzboio.adb new file mode 100644 index 00000000000..8763e48370c --- /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/a-zzboio.ads b/gcc/ada/libgnat/a-zzboio.ads similarity index 100% rename from gcc/ada/a-zzboio.ads rename to gcc/ada/libgnat/a-zzboio.ads diff --git a/gcc/ada/a-zzunio.ads b/gcc/ada/libgnat/a-zzunio.ads similarity index 100% rename from gcc/ada/a-zzunio.ads rename to gcc/ada/libgnat/a-zzunio.ads diff --git a/gcc/ada/libgnat/ada.ads b/gcc/ada/libgnat/ada.ads new file mode 100644 index 00000000000..1effebe9827 --- /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/calendar.ads b/gcc/ada/libgnat/calendar.ads similarity index 100% rename from gcc/ada/calendar.ads rename to gcc/ada/libgnat/calendar.ads diff --git a/gcc/ada/directio.ads b/gcc/ada/libgnat/directio.ads similarity index 100% rename from gcc/ada/directio.ads rename to gcc/ada/libgnat/directio.ads diff --git a/gcc/ada/libgnat/g-allein.ads b/gcc/ada/libgnat/g-allein.ads new file mode 100644 index 00000000000..5dc7fb4a825 --- /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 00000000000..4819211d320 --- /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 00000000000..63a0a67be6a --- /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 00000000000..faa3545064b --- /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 00000000000..5ecac0a991a --- /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 00000000000..8cce5a85132 --- /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 00000000000..b43cb655cab --- /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/g-altive.ads b/gcc/ada/libgnat/g-altive.ads similarity index 100% rename from gcc/ada/g-altive.ads rename to gcc/ada/libgnat/g-altive.ads diff --git a/gcc/ada/libgnat/g-alveop.adb b/gcc/ada/libgnat/g-alveop.adb new file mode 100644 index 00000000000..4e7317fcb18 --- /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 00000000000..39782bacb3c --- /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 00000000000..623a5fc373e --- /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 00000000000..35a25a7aff7 --- /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 00000000000..4e1e90e8116 --- /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 00000000000..d350face8d4 --- /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 00000000000..5086c020167 --- /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 00000000000..11330b66955 --- /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 00000000000..971e9d27a01 --- /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 00000000000..7a3424b9405 --- /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 00000000000..d0e4ed54404 --- /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 00000000000..8201c41363a --- /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 00000000000..983305824f8 --- /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 00000000000..cce64d9c5c1 --- /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 00000000000..f917a69e9d1 --- /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 00000000000..41a2194560a --- /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 00000000000..a1de878c0aa --- /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 00000000000..29e0757e556 --- /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 00000000000..8921dfb3bd6 --- /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 00000000000..d953f4f70cc --- /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 00000000000..a4aad21fbae --- /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 00000000000..44653b7ddff --- /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 00000000000..21df839e716 --- /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 00000000000..44774066bd4 --- /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/g-catiio.adb b/gcc/ada/libgnat/g-catiio.adb similarity index 100% rename from gcc/ada/g-catiio.adb rename to gcc/ada/libgnat/g-catiio.adb diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/libgnat/g-catiio.ads similarity index 100% rename from gcc/ada/g-catiio.ads rename to gcc/ada/libgnat/g-catiio.ads diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/libgnat/g-cgi.adb similarity index 100% rename from gcc/ada/g-cgi.adb rename to gcc/ada/libgnat/g-cgi.adb diff --git a/gcc/ada/libgnat/g-cgi.ads b/gcc/ada/libgnat/g-cgi.ads new file mode 100644 index 00000000000..7310d4529dc --- /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 00000000000..6733612aaf2 --- /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 00000000000..46751a411ac --- /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 00000000000..890c2dbd141 --- /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 00000000000..7a0337bb4ef --- /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/g-comlin.adb b/gcc/ada/libgnat/g-comlin.adb similarity index 100% rename from gcc/ada/g-comlin.adb rename to gcc/ada/libgnat/g-comlin.adb diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads new file mode 100644 index 00000000000..4ad239ba388 --- /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/g-comver.adb b/gcc/ada/libgnat/g-comver.adb similarity index 100% rename from gcc/ada/g-comver.adb rename to gcc/ada/libgnat/g-comver.adb diff --git a/gcc/ada/libgnat/g-comver.ads b/gcc/ada/libgnat/g-comver.ads new file mode 100644 index 00000000000..8707a49f806 --- /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 00000000000..473bb4322c5 --- /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 00000000000..7884e3e0ce4 --- /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 00000000000..b7f33364773 --- /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 00000000000..979c7bb0ace --- /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 00000000000..352de9cdbbf --- /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 00000000000..190554cea81 --- /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 00000000000..edc62b61dcf --- /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/g-debpoo.adb b/gcc/ada/libgnat/g-debpoo.adb similarity index 100% rename from gcc/ada/g-debpoo.adb rename to gcc/ada/libgnat/g-debpoo.adb diff --git a/gcc/ada/libgnat/g-debpoo.ads b/gcc/ada/libgnat/g-debpoo.ads new file mode 100644 index 00000000000..7cd3fa184b7 --- /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 00000000000..a7c30d06921 --- /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 00000000000..7e3dfe11b20 --- /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 00000000000..ab3bfd16d35 --- /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 00000000000..1572939c318 --- /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 00000000000..54306b8ca9e --- /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 00000000000..bc40d5d8741 --- /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 00000000000..9b65c19f65a --- /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/g-dirope.adb b/gcc/ada/libgnat/g-dirope.adb similarity index 100% rename from gcc/ada/g-dirope.adb rename to gcc/ada/libgnat/g-dirope.adb diff --git a/gcc/ada/libgnat/g-dirope.ads b/gcc/ada/libgnat/g-dirope.ads new file mode 100644 index 00000000000..6c004515e64 --- /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/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb similarity index 100% rename from gcc/ada/g-dynhta.adb rename to gcc/ada/libgnat/g-dynhta.adb diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads similarity index 100% rename from gcc/ada/g-dynhta.ads rename to gcc/ada/libgnat/g-dynhta.ads diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/libgnat/g-dyntab.adb similarity index 100% rename from gcc/ada/g-dyntab.adb rename to gcc/ada/libgnat/g-dyntab.adb diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads similarity index 100% rename from gcc/ada/g-dyntab.ads rename to gcc/ada/libgnat/g-dyntab.ads diff --git a/gcc/ada/libgnat/g-eacodu.adb b/gcc/ada/libgnat/g-eacodu.adb new file mode 100644 index 00000000000..30dca3da6c9 --- /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 00000000000..260e677269e --- /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 00000000000..a8aa6690ca3 --- /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 00000000000..f173084d3b1 --- /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 00000000000..a0899fa4180 --- /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 00000000000..f8ea04d1b2d --- /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/g-except.ads b/gcc/ada/libgnat/g-except.ads similarity index 100% rename from gcc/ada/g-except.ads rename to gcc/ada/libgnat/g-except.ads diff --git a/gcc/ada/libgnat/g-exctra.adb b/gcc/ada/libgnat/g-exctra.adb new file mode 100644 index 00000000000..ad30f4f6c1f --- /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 00000000000..cc93fd812d2 --- /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 00000000000..4435b6a1f6d --- /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 00000000000..0c05867e7e7 --- /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 00000000000..93f4d4985ee --- /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 00000000000..17c361c1160 --- /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 00000000000..5bc0a0d563b --- /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/g-forstr.adb b/gcc/ada/libgnat/g-forstr.adb similarity index 100% rename from gcc/ada/g-forstr.adb rename to gcc/ada/libgnat/g-forstr.adb diff --git a/gcc/ada/g-forstr.ads b/gcc/ada/libgnat/g-forstr.ads similarity index 100% rename from gcc/ada/g-forstr.ads rename to gcc/ada/libgnat/g-forstr.ads diff --git a/gcc/ada/libgnat/g-heasor.adb b/gcc/ada/libgnat/g-heasor.adb new file mode 100644 index 00000000000..4a47160d0b4 --- /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 00000000000..1adff7bd172 --- /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 00000000000..ba0a440314d --- /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 00000000000..a5a42ff0c03 --- /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 00000000000..a31a2192d06 --- /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 00000000000..67965bbcf26 --- /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 00000000000..633df394e56 --- /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 00000000000..c71d2c99432 --- /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 00000000000..65ee8db51bb --- /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 00000000000..765d07fa612 --- /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 00000000000..016d40bf286 --- /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 00000000000..1e5c27de12e --- /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 00000000000..0724286ac2b --- /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 00000000000..5e6d06bc2df --- /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 00000000000..e8665882fb6 --- /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 00000000000..33fc9d7c71a --- /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 00000000000..8d619656fcf --- /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 00000000000..e4537def460 --- /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 00000000000..f66217378df --- /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 00000000000..76ff5356a6b --- /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 00000000000..6867b5c2375 --- /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 00000000000..3cc8be13543 --- /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 00000000000..31503762c92 --- /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 00000000000..5f2777233db --- /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 00000000000..f94420cf4d6 --- /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 00000000000..1d692856cc3 --- /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 00000000000..5a4b03d410d --- /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 00000000000..773512e2681 --- /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 00000000000..d09c5bdf8c1 --- /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 00000000000..dd5c7f0929c --- /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 00000000000..d230d48de61 --- /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 00000000000..cdee8ff1a82 --- /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 00000000000..8e2e2c84d05 --- /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 00000000000..5b097bb1e4e --- /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 00000000000..806a06eac2c --- /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 00000000000..55f27103b47 --- /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 00000000000..c12096eda86 --- /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 00000000000..5f523c13ebd --- /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/g-rewdat.ads b/gcc/ada/libgnat/g-rewdat.ads similarity index 100% rename from gcc/ada/g-rewdat.ads rename to gcc/ada/libgnat/g-rewdat.ads diff --git a/gcc/ada/libgnat/g-sechas.adb b/gcc/ada/libgnat/g-sechas.adb new file mode 100644 index 00000000000..39c31622a35 --- /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/g-sechas.ads b/gcc/ada/libgnat/g-sechas.ads similarity index 100% rename from gcc/ada/g-sechas.ads rename to gcc/ada/libgnat/g-sechas.ads diff --git a/gcc/ada/libgnat/g-sehamd.adb b/gcc/ada/libgnat/g-sehamd.adb new file mode 100644 index 00000000000..616f15e7d5b --- /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 00000000000..5a19f34eb5a --- /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 00000000000..59d9dd48172 --- /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 00000000000..713eced70ad --- /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 00000000000..78e629fc4f0 --- /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 00000000000..ed78a523393 --- /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 00000000000..009d1a7a5fc --- /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 00000000000..652b93b26d2 --- /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 00000000000..d1764a49886 --- /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 00000000000..f27b88671ad --- /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 00000000000..c5fffe7f89b --- /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 00000000000..9d169f6110d --- /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 00000000000..255b520ab13 --- /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 00000000000..3e3aa3bbdbe --- /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 00000000000..da22788682b --- /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 00000000000..fece8cad0b4 --- /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 00000000000..573f9172103 --- /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 00000000000..1546e10ea82 --- /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 00000000000..00a0aea23fd --- /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 00000000000..8641a59e38f --- /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 00000000000..21a92ebf355 --- /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 00000000000..074a2e9d572 --- /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 00000000000..6cf2eab0ccb --- /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 00000000000..18caed94d0f --- /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/g-socket.adb b/gcc/ada/libgnat/g-socket.adb similarity index 100% rename from gcc/ada/g-socket.adb rename to gcc/ada/libgnat/g-socket.adb diff --git a/gcc/ada/g-socket.ads b/gcc/ada/libgnat/g-socket.ads similarity index 100% rename from gcc/ada/g-socket.ads rename to gcc/ada/libgnat/g-socket.ads diff --git a/gcc/ada/libgnat/g-socthi-dummy.adb b/gcc/ada/libgnat/g-socthi-dummy.adb new file mode 100644 index 00000000000..4ee3dfdaf3f --- /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 00000000000..53c49f4012b --- /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 00000000000..e0cde85d66a --- /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 00000000000..48f5aeb9bef --- /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 00000000000..05bedc2a1f9 --- /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 00000000000..9cb4018afcb --- /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 00000000000..635d0f58f34 --- /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 00000000000..0338f7f52ce --- /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 00000000000..25d5605824e --- /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 00000000000..734a2bc78be --- /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 00000000000..1898bb03c86 --- /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 00000000000..cd2ec9c0adf --- /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 00000000000..2f17b6c345f --- /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 00000000000..3739d643019 --- /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 00000000000..64def594c38 --- /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 00000000000..f0505119af5 --- /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 00000000000..55c9141af16 --- /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 00000000000..cc2179eb92b --- /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 00000000000..db6714eff94 --- /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 00000000000..501ed7b2295 --- /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/g-spipat.adb b/gcc/ada/libgnat/g-spipat.adb similarity index 100% rename from gcc/ada/g-spipat.adb rename to gcc/ada/libgnat/g-spipat.adb diff --git a/gcc/ada/libgnat/g-spipat.ads b/gcc/ada/libgnat/g-spipat.ads new file mode 100644 index 00000000000..dc59d298a94 --- /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 00000000000..64a4206f495 --- /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 00000000000..bfca2e21d85 --- /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 00000000000..96d75abd5da --- /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 00000000000..ac47bb22352 --- /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 00000000000..4b1801dee63 --- /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 00000000000..7db6644831a --- /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 00000000000..a6131062ab6 --- /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 00000000000..116fc28648e --- /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 00000000000..be4e795bcf9 --- /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 00000000000..37c9d06aab4 --- /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 00000000000..a1a0d57dbde --- /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 00000000000..b802f910b26 --- /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 00000000000..6f7bd3e34c5 --- /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 00000000000..e491e1a7572 --- /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/g-table.adb b/gcc/ada/libgnat/g-table.adb similarity index 100% rename from gcc/ada/g-table.adb rename to gcc/ada/libgnat/g-table.adb diff --git a/gcc/ada/g-table.ads b/gcc/ada/libgnat/g-table.ads similarity index 100% rename from gcc/ada/g-table.ads rename to gcc/ada/libgnat/g-table.ads diff --git a/gcc/ada/libgnat/g-tasloc.adb b/gcc/ada/libgnat/g-tasloc.adb new file mode 100644 index 00000000000..ffd4dcc3415 --- /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 00000000000..462f64bd2db --- /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 00000000000..316fec791ea --- /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 00000000000..80cbe244a10 --- /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 00000000000..2ceef67ef5e --- /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 00000000000..6256323c858 --- /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 00000000000..fe552aab199 --- /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 00000000000..f80bfd955ee --- /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 00000000000..be9e7ebbfb7 --- /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 00000000000..7fe657bc99f --- /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 00000000000..d80c8c56f15 --- /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 00000000000..d87890c4e3f --- /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 00000000000..ce75555bbd2 --- /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 00000000000..cbbc5b6ec71 --- /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 00000000000..b09c1dee9ed --- /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 00000000000..9e4d7608e09 --- /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 00000000000..bc345926b89 --- /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 00000000000..420667d2a29 --- /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 00000000000..40fa53f916b --- /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 00000000000..3d45beba362 --- /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 00000000000..8710029fcb4 --- /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 00000000000..26aab1b7ecb --- /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/i-c.ads b/gcc/ada/libgnat/i-c.ads similarity index 100% rename from gcc/ada/i-c.ads rename to gcc/ada/libgnat/i-c.ads diff --git a/gcc/ada/libgnat/i-cexten.ads b/gcc/ada/libgnat/i-cexten.ads new file mode 100644 index 00000000000..bcbfd987357 --- /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 00000000000..d87c00a4394 --- /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 00000000000..31ef99f57c4 --- /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 00000000000..6bb86202aba --- /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 00000000000..83eb31d7b97 --- /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 00000000000..a6ece8794a6 --- /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 00000000000..21fc1664b5b --- /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 00000000000..5a1f51b15ad --- /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 00000000000..5ab8d665d37 --- /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 00000000000..b2ead3812de --- /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/i-fortra.ads b/gcc/ada/libgnat/i-fortra.ads similarity index 100% rename from gcc/ada/i-fortra.ads rename to gcc/ada/libgnat/i-fortra.ads diff --git a/gcc/ada/libgnat/i-pacdec.adb b/gcc/ada/libgnat/i-pacdec.adb new file mode 100644 index 00000000000..aa2f289fcc2 --- /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 00000000000..1f312b91612 --- /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 00000000000..c908a2b3553 --- /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 00000000000..9a6929f4f68 --- /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 00000000000..ef515d57564 --- /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 00000000000..b6e036b2d0c --- /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 00000000000..da387f549b5 --- /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/ioexcept.ads b/gcc/ada/libgnat/ioexcept.ads similarity index 100% rename from gcc/ada/ioexcept.ads rename to gcc/ada/libgnat/ioexcept.ads diff --git a/gcc/ada/machcode.ads b/gcc/ada/libgnat/machcode.ads similarity index 100% rename from gcc/ada/machcode.ads rename to gcc/ada/libgnat/machcode.ads diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb new file mode 100644 index 00000000000..bab458d5d2a --- /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 00000000000..8af30643fe2 --- /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 00000000000..2dafd3c637b --- /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 00000000000..a19e40b88e0 --- /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 00000000000..8a11b690f69 --- /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 00000000000..2149486c4e4 --- /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 00000000000..921ffcde469 --- /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 00000000000..e02ffd1d66b --- /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 00000000000..3fe02a767eb --- /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 00000000000..efdc42ab9df --- /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 00000000000..f006cb2a879 --- /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 00000000000..1b5b66a031f --- /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 00000000000..eb69a49e616 --- /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 00000000000..9057c5f8c74 --- /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 00000000000..ddef9efe649 --- /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 00000000000..91a2ba80198 --- /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 00000000000..b9c9251c3cf --- /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 00000000000..5bee94ac335 --- /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 00000000000..d3086c77e9b --- /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 00000000000..3f31a443810 --- /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 00000000000..dd559b39ef6 --- /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 00000000000..effc04614bb --- /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 00000000000..1b6b3ba9881 --- /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 00000000000..06cc4a902d9 --- /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 00000000000..1fba4793dd3 --- /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 00000000000..458678a1e35 --- /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 00000000000..ab1e5d0b20a --- /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 00000000000..303d8734df3 --- /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 00000000000..6aedc54e149 --- /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 00000000000..65c867c2817 --- /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 00000000000..f2328a17a09 --- /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 00000000000..01f788edbb5 --- /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 00000000000..bf2be624b1a --- /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 00000000000..6cfebeb4bc7 --- /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 00000000000..27afe68bdaa --- /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 00000000000..84c08e45030 --- /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 00000000000..8d9f387c90b --- /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 00000000000..96cc9ab4008 --- /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 00000000000..6b37c95fe1f --- /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 00000000000..720febd2763 --- /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 00000000000..73f14b4862c --- /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 00000000000..c61a97a761f --- /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 00000000000..64fad02696a --- /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 00000000000..43076f55ed0 --- /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 00000000000..0322dd2951b --- /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 00000000000..9e68d3b349f --- /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 00000000000..671c6de165b --- /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 00000000000..7c8a757bf59 --- /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 00000000000..89c9ee01f1b --- /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 00000000000..b950f0b51ec --- /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 00000000000..06f8ec24231 --- /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 00000000000..c24df1478c2 --- /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 00000000000..f081cf295ba --- /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 00000000000..33194e09db9 --- /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 00000000000..085420e04d3 --- /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 00000000000..ac45d5bc3af --- /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 00000000000..8773e0d0d25 --- /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 00000000000..acbb8a6d819 --- /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 00000000000..df4578516f9 --- /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 00000000000..601c6c0cb4f --- /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 00000000000..c81fd2440f6 --- /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 00000000000..19948d400ef --- /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 00000000000..b71d63a386a --- /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 00000000000..f2f862fb2b0 --- /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 00000000000..c542855c190 --- /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 00000000000..7459c9ea9b3 --- /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 00000000000..b5a28388662 --- /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 00000000000..4c8f46cb559 --- /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/s-diflio.ads b/gcc/ada/libgnat/s-diflio.ads similarity index 100% rename from gcc/ada/s-diflio.ads rename to gcc/ada/libgnat/s-diflio.ads diff --git a/gcc/ada/libgnat/s-diinio.adb b/gcc/ada/libgnat/s-diinio.adb new file mode 100644 index 00000000000..2411962071c --- /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/s-diinio.ads b/gcc/ada/libgnat/s-diinio.ads similarity index 100% rename from gcc/ada/s-diinio.ads rename to gcc/ada/libgnat/s-diinio.ads diff --git a/gcc/ada/libgnat/s-dim.ads b/gcc/ada/libgnat/s-dim.ads new file mode 100644 index 00000000000..d9143300c9c --- /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 00000000000..7fd39b36f04 --- /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 00000000000..fddca86a153 --- /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 00000000000..bd285264485 --- /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 00000000000..5bda65ff4a1 --- /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 00000000000..c17e55e253c --- /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 00000000000..5191e24345a --- /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/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb similarity index 100% rename from gcc/ada/s-dwalin.adb rename to gcc/ada/libgnat/s-dwalin.adb diff --git a/gcc/ada/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads similarity index 100% rename from gcc/ada/s-dwalin.ads rename to gcc/ada/libgnat/s-dwalin.ads diff --git a/gcc/ada/libgnat/s-elaall.adb b/gcc/ada/libgnat/s-elaall.adb new file mode 100644 index 00000000000..4ed92bedd51 --- /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 00000000000..7dc47a0279f --- /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 00000000000..7eef8e1199a --- /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 00000000000..5d9533e63c6 --- /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 00000000000..e48d06099a6 --- /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 00000000000..d33bea6bfa4 --- /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/s-excmac-arm.adb b/gcc/ada/libgnat/s-excmac-arm.adb similarity index 100% rename from gcc/ada/s-excmac-arm.adb rename to gcc/ada/libgnat/s-excmac-arm.adb diff --git a/gcc/ada/s-excmac-arm.ads b/gcc/ada/libgnat/s-excmac-arm.ads similarity index 100% rename from gcc/ada/s-excmac-arm.ads rename to gcc/ada/libgnat/s-excmac-arm.ads diff --git a/gcc/ada/s-excmac-gcc.adb b/gcc/ada/libgnat/s-excmac-gcc.adb similarity index 100% rename from gcc/ada/s-excmac-gcc.adb rename to gcc/ada/libgnat/s-excmac-gcc.adb diff --git a/gcc/ada/s-excmac-gcc.ads b/gcc/ada/libgnat/s-excmac-gcc.ads similarity index 100% rename from gcc/ada/s-excmac-gcc.ads rename to gcc/ada/libgnat/s-excmac-gcc.ads diff --git a/gcc/ada/libgnat/s-exctab.adb b/gcc/ada/libgnat/s-exctab.adb new file mode 100644 index 00000000000..adbf1f44896 --- /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 00000000000..e3c8a1a5287 --- /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 00000000000..e1c899558e5 --- /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 00000000000..e840f49e5ab --- /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 00000000000..f4dd970924c --- /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 00000000000..a42648fde4b --- /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 00000000000..885fbe16380 --- /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 00000000000..a58ca744d9a --- /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 00000000000..701a031e3e8 --- /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 00000000000..06b895d871f --- /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 00000000000..49b98e06cfe --- /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 00000000000..103325dd6da --- /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 00000000000..4d7dc47633c --- /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 00000000000..74858eeb727 --- /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 00000000000..3875806f1c6 --- /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 00000000000..d23bd2bd41c --- /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 00000000000..2c2e857559c --- /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 00000000000..49ace2d60f2 --- /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 00000000000..ad0c3bd1167 --- /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 00000000000..b0f3dc354e3 --- /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 00000000000..d6e08182da3 --- /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/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb similarity index 100% rename from gcc/ada/s-fatgen.adb rename to gcc/ada/libgnat/s-fatgen.adb diff --git a/gcc/ada/libgnat/s-fatgen.ads b/gcc/ada/libgnat/s-fatgen.ads new file mode 100644 index 00000000000..b9f37905d0b --- /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 00000000000..4cdce2475ce --- /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 00000000000..46ab4ec6635 --- /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 00000000000..c863a134931 --- /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 00000000000..abe894cf135 --- /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 00000000000..9cfc55ad7af --- /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/s-fileio.adb b/gcc/ada/libgnat/s-fileio.adb similarity index 100% rename from gcc/ada/s-fileio.adb rename to gcc/ada/libgnat/s-fileio.adb diff --git a/gcc/ada/libgnat/s-fileio.ads b/gcc/ada/libgnat/s-fileio.ads new file mode 100644 index 00000000000..bcd2e6cf21c --- /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 00000000000..85ee481a704 --- /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/s-finmas.ads b/gcc/ada/libgnat/s-finmas.ads similarity index 100% rename from gcc/ada/s-finmas.ads rename to gcc/ada/libgnat/s-finmas.ads diff --git a/gcc/ada/libgnat/s-finroo.adb b/gcc/ada/libgnat/s-finroo.adb new file mode 100644 index 00000000000..6b65bd89298 --- /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 00000000000..83d322727ed --- /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 00000000000..582623797a3 --- /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 00000000000..31669d54042 --- /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 00000000000..1033e8eefa6 --- /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 00000000000..9d1933ca111 --- /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 00000000000..f7e252ec77d --- /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 00000000000..5368028060a --- /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 00000000000..cde4d134fd2 --- /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 00000000000..a5ebc78a909 --- /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 00000000000..26e5888c676 --- /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 00000000000..404f1c89a0c --- /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 00000000000..7646c522bae --- /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 00000000000..f85247f3c29 --- /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/s-htable.adb b/gcc/ada/libgnat/s-htable.adb similarity index 100% rename from gcc/ada/s-htable.adb rename to gcc/ada/libgnat/s-htable.adb diff --git a/gcc/ada/libgnat/s-htable.ads b/gcc/ada/libgnat/s-htable.ads new file mode 100644 index 00000000000..b6d9960167b --- /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 00000000000..c57e66bf7e5 --- /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 00000000000..8d169e30865 --- /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 00000000000..b0aa714537b --- /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 00000000000..4a1a5ccd5bf --- /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 00000000000..618d0aa04c3 --- /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 00000000000..8b275110e99 --- /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 00000000000..30b03882dd5 --- /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 00000000000..604bc88babf --- /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 00000000000..765a7e8ef34 --- /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 00000000000..9534952931b --- /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 00000000000..7efad432ddc --- /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 00000000000..716328c56c4 --- /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 00000000000..551a9e8ec8f --- /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 00000000000..d1cfcdca73f --- /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 00000000000..769ad23eda5 --- /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 00000000000..a569a2f7bae --- /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 00000000000..a76b2b09ecf --- /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 00000000000..58d0405422a --- /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 00000000000..b2dc8f64e2d --- /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 00000000000..5354b8c19f4 --- /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 00000000000..d14a5da180f --- /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 00000000000..bc3989203f4 --- /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 00000000000..b0236dbdc67 --- /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 00000000000..ce11d343a49 --- /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 00000000000..61b32c87c5b --- /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 00000000000..baefd9ad8cc --- /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 00000000000..c6d467bdbd9 --- /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 00000000000..8348c607c24 --- /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 00000000000..4025d18f6a2 --- /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 00000000000..ce5c9eb352b --- /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 00000000000..fbb92ef31bc --- /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 00000000000..8fb23a2527b --- /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 00000000000..7f45d5d62d4 --- /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 00000000000..9186de20337 --- /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 00000000000..8ada509e92a --- /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 00000000000..37bc7b4c09e --- /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 00000000000..8e2f7b68de4 --- /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 00000000000..424589b169a --- /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 00000000000..8b84495b820 --- /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 00000000000..19b8689e6fa --- /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 00000000000..d96fd1f0b01 --- /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 00000000000..f7e5ff813dc --- /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 00000000000..28b58179fc4 --- /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 00000000000..a911ce776de --- /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 00000000000..6c8fbc2bfa6 --- /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 00000000000..4ab2ffcdfe3 --- /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 00000000000..8a1f94a1ccb --- /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 00000000000..f32e540ebfe --- /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 00000000000..3610065dff7 --- /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 00000000000..aec253859f5 --- /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 00000000000..7162ddc351c --- /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 00000000000..166cf308c01 --- /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/s-multip.ads b/gcc/ada/libgnat/s-multip.ads similarity index 100% rename from gcc/ada/s-multip.ads rename to gcc/ada/libgnat/s-multip.ads diff --git a/gcc/ada/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb similarity index 100% rename from gcc/ada/s-objrea.adb rename to gcc/ada/libgnat/s-objrea.adb diff --git a/gcc/ada/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads similarity index 100% rename from gcc/ada/s-objrea.ads rename to gcc/ada/libgnat/s-objrea.ads diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb similarity index 100% rename from gcc/ada/s-os_lib.adb rename to gcc/ada/libgnat/s-os_lib.adb diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads similarity index 100% rename from gcc/ada/s-os_lib.ads rename to gcc/ada/libgnat/s-os_lib.ads diff --git a/gcc/ada/libgnat/s-osprim-darwin.adb b/gcc/ada/libgnat/s-osprim-darwin.adb new file mode 100644 index 00000000000..b0f5fff2a09 --- /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 00000000000..d729d857a74 --- /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 00000000000..8911b16b3a9 --- /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 00000000000..dd977a85414 --- /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 00000000000..c1c7e75401b --- /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 00000000000..f273df65900 --- /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 00000000000..2fa6cfe9025 --- /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 00000000000..809e16348a0 --- /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 00000000000..074a92d3f2f --- /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 00000000000..c31381cad29 --- /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 00000000000..4dbe90440ee --- /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 00000000000..d262bdd6c44 --- /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 00000000000..b22796e09e0 --- /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 00000000000..f7211e39cb5 --- /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 00000000000..92e57935158 --- /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 00000000000..ec5b806cd47 --- /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 00000000000..b907c9875e0 --- /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 00000000000..3a605d2a1e7 --- /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 00000000000..faa061ff625 --- /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 00000000000..1fc22a6ace0 --- /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 00000000000..2382fd637ad --- /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 00000000000..5be409b8f6d --- /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 00000000000..f759a7070d0 --- /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 00000000000..a5f9f86675c --- /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 00000000000..75e733a027a --- /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 00000000000..7698fb20afc --- /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 00000000000..ec2ae9d0c49 --- /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 00000000000..4594fb3a30c --- /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 00000000000..ac172c980bf --- /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 00000000000..151c227a477 --- /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 00000000000..b38230bc090 --- /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 00000000000..d761f8479bf --- /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 00000000000..f7d9a490005 --- /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 00000000000..a6ca62bf42f --- /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 00000000000..7eabf52365a --- /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 00000000000..35913b42ef9 --- /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 00000000000..5801fb2fcc3 --- /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 00000000000..b3f7b0b1d0a --- /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 00000000000..cfcf13b00cc --- /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 00000000000..067c4de9871 --- /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 00000000000..4958e88f49c --- /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 00000000000..c7816fc3ffd --- /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 00000000000..8a080be7fed --- /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 00000000000..9cb6e5b3755 --- /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 00000000000..b993f54d9d5 --- /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 00000000000..be006a9533e --- /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 00000000000..c5da2ab75f8 --- /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 00000000000..e22472f2464 --- /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 00000000000..b915fb3fc9b --- /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 00000000000..c4b4542f703 --- /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 00000000000..bc0d8633e62 --- /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 00000000000..bba4537f44f --- /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 00000000000..f7600434501 --- /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 00000000000..3d1522a3443 --- /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 00000000000..33457160214 --- /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 00000000000..a8315d4f59f --- /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 00000000000..fb408efa88b --- /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 00000000000..baff460bd03 --- /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 00000000000..5679368f20d --- /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 00000000000..c9c04dcdf73 --- /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 00000000000..86337ac1cb9 --- /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 00000000000..4218670305a --- /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 00000000000..5a9e6cfefdb --- /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 00000000000..79b3c4af56b --- /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 00000000000..7aac4bb04db --- /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 00000000000..1a5d19dbf6e --- /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 00000000000..c38e8a6999e --- /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 00000000000..c539e20404b --- /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 00000000000..f4b2a1039df --- /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 00000000000..ba477a4a376 --- /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 00000000000..e8da8cf08a4 --- /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 00000000000..47c436896a8 --- /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 00000000000..08144871e23 --- /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 00000000000..beb675ab0b4 --- /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 00000000000..e3cf8364391 --- /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 00000000000..f0056b96cd7 --- /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 00000000000..3f430403817 --- /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 00000000000..2d7b47b8f93 --- /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 00000000000..041655718c6 --- /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 00000000000..037760450e9 --- /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 00000000000..ed468a8011a --- /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 00000000000..ea96d32cab4 --- /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 00000000000..d37616bc68c --- /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 00000000000..7088cf86354 --- /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 00000000000..20fd41bd089 --- /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 00000000000..9b81ccc34a6 --- /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 00000000000..b406c20d7e8 --- /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 00000000000..fc5d60b4e7e --- /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 00000000000..60a7f27e02b --- /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 00000000000..3354a036fa5 --- /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 00000000000..a29399e50b7 --- /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 00000000000..26e3165c6da --- /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 00000000000..68c5562275c --- /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 00000000000..0a13077ace2 --- /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 00000000000..3c1f74b2f41 --- /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 00000000000..845630ce30c --- /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 00000000000..7b952d6b94d --- /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 00000000000..217e230845a --- /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 00000000000..d95dd42965e --- /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 00000000000..37b583fd9bf --- /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 00000000000..27a5b93ee28 --- /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 00000000000..f5e87128ec5 --- /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 00000000000..89badf4be40 --- /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 00000000000..45fdfdcc6da --- /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 00000000000..936c39129e9 --- /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 00000000000..3b9d26b44af --- /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 00000000000..de587f96a5f --- /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 00000000000..f6dd75053ee --- /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 00000000000..ef354bae7f3 --- /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 00000000000..7cc581359a7 --- /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 00000000000..75272e76ea2 --- /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 00000000000..3ed545b9181 --- /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 00000000000..eb45a42e4df --- /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 00000000000..312177fcf34 --- /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 00000000000..c52fb207912 --- /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 00000000000..4ca53b5fca0 --- /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 00000000000..cd30299a3a8 --- /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 00000000000..62224b1f3c3 --- /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 00000000000..c247233a83f --- /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 00000000000..f0e774fafa8 --- /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 00000000000..c019532b989 --- /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 00000000000..bbaf91438ed --- /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 00000000000..e0872c39971 --- /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/s-parame-hpux.ads b/gcc/ada/libgnat/s-parame-hpux.ads similarity index 100% rename from gcc/ada/s-parame-hpux.ads rename to gcc/ada/libgnat/s-parame-hpux.ads diff --git a/gcc/ada/s-parame-rtems.adb b/gcc/ada/libgnat/s-parame-rtems.adb similarity index 100% rename from gcc/ada/s-parame-rtems.adb rename to gcc/ada/libgnat/s-parame-rtems.adb diff --git a/gcc/ada/libgnat/s-parame-vxworks.adb b/gcc/ada/libgnat/s-parame-vxworks.adb new file mode 100644 index 00000000000..325aa2e4f08 --- /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/s-parame-vxworks.ads b/gcc/ada/libgnat/s-parame-vxworks.ads similarity index 100% rename from gcc/ada/s-parame-vxworks.ads rename to gcc/ada/libgnat/s-parame-vxworks.ads diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb new file mode 100644 index 00000000000..0f4d45f2da8 --- /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/s-parame.ads b/gcc/ada/libgnat/s-parame.ads similarity index 100% rename from gcc/ada/s-parame.ads rename to gcc/ada/libgnat/s-parame.ads diff --git a/gcc/ada/libgnat/s-parint.adb b/gcc/ada/libgnat/s-parint.adb new file mode 100644 index 00000000000..8d2e83a7db0 --- /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 00000000000..b64d4563aa3 --- /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 00000000000..109dff06565 --- /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 00000000000..294f4ebd858 --- /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 00000000000..46116671b33 --- /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 00000000000..3891c2e2c17 --- /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 00000000000..8b268d061b4 --- /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 00000000000..092548ea41a --- /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 00000000000..a41fc60a467 --- /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/s-purexc.ads b/gcc/ada/libgnat/s-purexc.ads similarity index 100% rename from gcc/ada/s-purexc.ads rename to gcc/ada/libgnat/s-purexc.ads diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb new file mode 100644 index 00000000000..002cf0cd754 --- /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 00000000000..e76a56d0260 --- /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 00000000000..e5639526a4a --- /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 00000000000..ff76ed09df2 --- /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/s-regexp.adb b/gcc/ada/libgnat/s-regexp.adb similarity index 100% rename from gcc/ada/s-regexp.adb rename to gcc/ada/libgnat/s-regexp.adb diff --git a/gcc/ada/s-regexp.ads b/gcc/ada/libgnat/s-regexp.ads similarity index 100% rename from gcc/ada/s-regexp.ads rename to gcc/ada/libgnat/s-regexp.ads diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb similarity index 100% rename from gcc/ada/s-regpat.adb rename to gcc/ada/libgnat/s-regpat.adb diff --git a/gcc/ada/libgnat/s-regpat.ads b/gcc/ada/libgnat/s-regpat.ads new file mode 100644 index 00000000000..9f44d1d6e88 --- /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/s-resfil.adb b/gcc/ada/libgnat/s-resfil.adb similarity index 100% rename from gcc/ada/s-resfil.adb rename to gcc/ada/libgnat/s-resfil.adb diff --git a/gcc/ada/s-resfil.ads b/gcc/ada/libgnat/s-resfil.ads similarity index 100% rename from gcc/ada/s-resfil.ads rename to gcc/ada/libgnat/s-resfil.ads diff --git a/gcc/ada/libgnat/s-restri.adb b/gcc/ada/libgnat/s-restri.adb new file mode 100644 index 00000000000..bef2f005c4e --- /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 00000000000..82b5e8874b6 --- /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/s-rident.ads b/gcc/ada/libgnat/s-rident.ads similarity index 100% rename from gcc/ada/s-rident.ads rename to gcc/ada/libgnat/s-rident.ads diff --git a/gcc/ada/libgnat/s-rpc.adb b/gcc/ada/libgnat/s-rpc.adb new file mode 100644 index 00000000000..ac15c330627 --- /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 00000000000..f0bb8d0099f --- /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 00000000000..c3492b06ad2 --- /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 00000000000..9292dcd231f --- /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 00000000000..0449ee4dbcd --- /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 00000000000..534708d1a6f --- /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 00000000000..b5616aed8a6 --- /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 00000000000..4d7f19e1b06 --- /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 00000000000..9395e3f6e10 --- /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 00000000000..febaf43e60e --- /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 00000000000..f604f4df3be --- /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 00000000000..402ea84818b --- /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 00000000000..85c183c5569 --- /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 00000000000..eee4667fb25 --- /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 00000000000..a6dcb032ff3 --- /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 00000000000..3020cca8f9f --- /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 00000000000..8765b53bc56 --- /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 00000000000..180503e9715 --- /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 00000000000..11846c996f2 --- /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 00000000000..e4091ace77a --- /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 00000000000..8be4293e06a --- /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 00000000000..8f3060f1d45 --- /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 00000000000..07fb21a7ec7 --- /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 00000000000..d066b0d4b25 --- /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 00000000000..f652e7a4732 --- /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 00000000000..34615e24689 --- /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 00000000000..6ab2f0a5787 --- /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/s-stchop-rtems.adb b/gcc/ada/libgnat/s-stchop-rtems.adb similarity index 100% rename from gcc/ada/s-stchop-rtems.adb rename to gcc/ada/libgnat/s-stchop-rtems.adb diff --git a/gcc/ada/libgnat/s-stchop-vxworks.adb b/gcc/ada/libgnat/s-stchop-vxworks.adb new file mode 100644 index 00000000000..25b07db7a4e --- /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 00000000000..3bae051d069 --- /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 00000000000..16a3939a477 --- /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 00000000000..e517f7015cc --- /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 00000000000..c553540af02 --- /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 00000000000..1033f862983 --- /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 00000000000..4d5ce9bb7f7 --- /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/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb similarity index 100% rename from gcc/ada/s-stposu.adb rename to gcc/ada/libgnat/s-stposu.adb diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads new file mode 100644 index 00000000000..165542dd3c8 --- /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 00000000000..f7c63ce1b71 --- /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 00000000000..91196f7e701 --- /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 00000000000..ce0dfa2ab50 --- /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 00000000000..1ac7e08b06a --- /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 00000000000..8315f37a64a --- /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 00000000000..98bc1540b41 --- /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 00000000000..444d7fec5a4 --- /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 00000000000..92b55d76da6 --- /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 00000000000..d6fff14b51d --- /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 00000000000..3665cf15087 --- /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 00000000000..78a5b253f49 --- /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/s-ststop.adb b/gcc/ada/libgnat/s-ststop.adb similarity index 100% rename from gcc/ada/s-ststop.adb rename to gcc/ada/libgnat/s-ststop.adb diff --git a/gcc/ada/s-ststop.ads b/gcc/ada/libgnat/s-ststop.ads similarity index 100% rename from gcc/ada/s-ststop.ads rename to gcc/ada/libgnat/s-ststop.ads diff --git a/gcc/ada/libgnat/s-tasloc.adb b/gcc/ada/libgnat/s-tasloc.adb new file mode 100644 index 00000000000..943f4192002 --- /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 00000000000..18a4570fbde --- /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 00000000000..cd4faaec1ed --- /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 00000000000..a261104d4d6 --- /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 00000000000..422d5c591a3 --- /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 00000000000..c923a617411 --- /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 00000000000..81ab8f92a6c --- /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 00000000000..c9c037b2dc4 --- /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 00000000000..fe4349e3149 --- /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/s-trasym-dwarf.adb b/gcc/ada/libgnat/s-trasym-dwarf.adb similarity index 100% rename from gcc/ada/s-trasym-dwarf.adb rename to gcc/ada/libgnat/s-trasym-dwarf.adb diff --git a/gcc/ada/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb similarity index 100% rename from gcc/ada/s-trasym.adb rename to gcc/ada/libgnat/s-trasym.adb diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads new file mode 100644 index 00000000000..04b9be8b874 --- /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/s-tsmona-linux.adb b/gcc/ada/libgnat/s-tsmona-linux.adb similarity index 100% rename from gcc/ada/s-tsmona-linux.adb rename to gcc/ada/libgnat/s-tsmona-linux.adb diff --git a/gcc/ada/s-tsmona-mingw.adb b/gcc/ada/libgnat/s-tsmona-mingw.adb similarity index 100% rename from gcc/ada/s-tsmona-mingw.adb rename to gcc/ada/libgnat/s-tsmona-mingw.adb diff --git a/gcc/ada/libgnat/s-tsmona.adb b/gcc/ada/libgnat/s-tsmona.adb new file mode 100644 index 00000000000..95edb6b7e13 --- /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 00000000000..97bd3370839 --- /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 00000000000..8871a568514 --- /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 00000000000..bfff8a8c91a --- /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 00000000000..05aa904d845 --- /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 00000000000..16d5199ba4b --- /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 00000000000..1a12a8bf07e --- /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 00000000000..d7d50b58759 --- /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 00000000000..63f79d674a5 --- /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 00000000000..759dc72a5ef --- /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 00000000000..d52b0541597 --- /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 00000000000..3f88f9c1877 --- /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 00000000000..89586617e16 --- /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 00000000000..4f651be8f25 --- /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 00000000000..b1cf678a185 --- /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 00000000000..d2cde625d57 --- /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 00000000000..0d1dfd5f93c --- /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 00000000000..c7333b52a6c --- /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 00000000000..3b14e6aa4e0 --- /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 00000000000..127cb065f41 --- /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 00000000000..c5c905f288a --- /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 00000000000..2e2bb649421 --- /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 00000000000..b0d379049b1 --- /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 00000000000..244733bdf04 --- /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 00000000000..72df4d531b6 --- /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 00000000000..c7b35338dae --- /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 00000000000..7ae423b8d64 --- /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 00000000000..b503157bcb1 --- /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 00000000000..104f73aa137 --- /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 00000000000..27e6f4f9313 --- /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 00000000000..94e1040ac98 --- /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 00000000000..ddecc16c289 --- /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 00000000000..903c4a6230b --- /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 00000000000..97ef6a1ca9c --- /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 00000000000..e807bb4da31 --- /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 00000000000..560ec8433ef --- /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 00000000000..ca40d913e4a --- /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 00000000000..8b2da7692ce --- /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 00000000000..772845dd057 --- /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 00000000000..f55808b2a98 --- /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 00000000000..4240571e0d7 --- /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 00000000000..4c116ed5061 --- /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 00000000000..670d241f7d6 --- /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 00000000000..648d7bd7428 --- /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 00000000000..09c6a491890 --- /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 00000000000..95cd31a78bb --- /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 00000000000..5f238c93d71 --- /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 00000000000..d2daf5717bc --- /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 00000000000..7e1d18b81f6 --- /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 00000000000..947ab6aafb3 --- /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 00000000000..ec778ebc881 --- /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 00000000000..898ff8fa6f5 --- /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 00000000000..f7191638d5f --- /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 00000000000..5b91b56f326 --- /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 00000000000..812496ece10 --- /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 00000000000..b23ad842a26 --- /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 00000000000..240499462b7 --- /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 00000000000..b20695281cf --- /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 00000000000..34046aa66b8 --- /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 00000000000..ce06edada49 --- /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 00000000000..47ec49d441d --- /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 00000000000..abccb03736a --- /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 00000000000..f50bba54af3 --- /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/sequenio.ads b/gcc/ada/libgnat/sequenio.ads similarity index 100% rename from gcc/ada/sequenio.ads rename to gcc/ada/libgnat/sequenio.ads diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads new file mode 100644 index 00000000000..3a381434759 --- /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 00000000000..620ff1bd30f --- /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 00000000000..675402f4ce2 --- /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 00000000000..7f3b35030bf --- /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/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads similarity index 100% rename from gcc/ada/system-djgpp.ads rename to gcc/ada/libgnat/system-djgpp.ads diff --git a/gcc/ada/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads similarity index 100% rename from gcc/ada/system-dragonfly-x86_64.ads rename to gcc/ada/libgnat/system-dragonfly-x86_64.ads diff --git a/gcc/ada/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads similarity index 100% rename from gcc/ada/system-freebsd.ads rename to gcc/ada/libgnat/system-freebsd.ads diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads new file mode 100644 index 00000000000..975ce90b2e2 --- /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 00000000000..c068c92dc4c --- /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 00000000000..274e8949cb0 --- /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/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads similarity index 100% rename from gcc/ada/system-linux-arm.ads rename to gcc/ada/libgnat/system-linux-arm.ads diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads new file mode 100644 index 00000000000..5a7c80ba4e0 --- /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 00000000000..65d2a77a96e --- /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/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads similarity index 100% rename from gcc/ada/system-linux-m68k.ads rename to gcc/ada/libgnat/system-linux-m68k.ads diff --git a/gcc/ada/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads similarity index 100% rename from gcc/ada/system-linux-mips.ads rename to gcc/ada/libgnat/system-linux-mips.ads diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads similarity index 100% rename from gcc/ada/system-linux-ppc.ads rename to gcc/ada/libgnat/system-linux-ppc.ads diff --git a/gcc/ada/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads similarity index 100% rename from gcc/ada/system-linux-s390.ads rename to gcc/ada/libgnat/system-linux-s390.ads diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads new file mode 100644 index 00000000000..43828bfaf21 --- /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 00000000000..8227a0d7bdd --- /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/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads similarity index 100% rename from gcc/ada/system-linux-x86.ads rename to gcc/ada/libgnat/system-linux-x86.ads diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads new file mode 100644 index 00000000000..3aeaa23b0e9 --- /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/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads similarity index 100% rename from gcc/ada/system-rtems.ads rename to gcc/ada/libgnat/system-rtems.ads diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads new file mode 100644 index 00000000000..7391ca6aadd --- /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 00000000000..f600aec2735 --- /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 00000000000..b51f998584d --- /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 00000000000..c29bc009623 --- /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 00000000000..80884446ad1 --- /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 00000000000..7fa7cc50c99 --- /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 00000000000..b739d12c467 --- /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 00000000000..c308a45d290 --- /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 00000000000..2579f47832d --- /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 00000000000..4ac597ed637 --- /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 00000000000..24d7e46ab4e --- /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 00000000000..7d2cd5100b3 --- /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 00000000000..a427f8d03aa --- /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 00000000000..cad12683b7c --- /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 00000000000..9299485ef83 --- /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 00000000000..be4aebf8b89 --- /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 00000000000..aeac6c5f9bb --- /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 00000000000..5e385be4f67 --- /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 00000000000..86001230883 --- /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 00000000000..cb74f236dce --- /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 00000000000..30e7be5f974 --- /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 00000000000..8b96e2347f0 --- /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 00000000000..51c7e75a878 --- /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 00000000000..83708da7233 --- /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 00000000000..63603fc128a --- /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 00000000000..8a97086a6a1 --- /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 00000000000..e18602366f2 --- /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 00000000000..a5ea9299b12 --- /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 00000000000..257ef2635ca --- /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 00000000000..e97588e6dd1 --- /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/system.ads b/gcc/ada/libgnat/system.ads similarity index 100% rename from gcc/ada/system.ads rename to gcc/ada/libgnat/system.ads diff --git a/gcc/ada/text_io.ads b/gcc/ada/libgnat/text_io.ads similarity index 100% rename from gcc/ada/text_io.ads rename to gcc/ada/libgnat/text_io.ads diff --git a/gcc/ada/unchconv.ads b/gcc/ada/libgnat/unchconv.ads similarity index 100% rename from gcc/ada/unchconv.ads rename to gcc/ada/libgnat/unchconv.ads diff --git a/gcc/ada/unchdeal.ads b/gcc/ada/libgnat/unchdeal.ads similarity index 100% rename from gcc/ada/unchdeal.ads rename to gcc/ada/libgnat/unchdeal.ads diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb deleted file mode 100644 index 869990de95a..00000000000 --- 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 cfde5c101ee..00000000000 --- 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 c81c2290aaf..00000000000 --- 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 e38fba4e2ba..00000000000 --- 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 7d1866b4f4d..00000000000 --- 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 cbefe3111fb..00000000000 --- 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 4eb115305ba..00000000000 --- 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 3828cc13b2b..00000000000 --- 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 38cab863426..00000000000 --- 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 f1998fa71f8..00000000000 --- 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 fb6232d14ae..00000000000 --- 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 36a939fd89e..00000000000 --- 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 bee6755485b..00000000000 --- 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 2897c6c8368..00000000000 --- 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 1147de7b45f..00000000000 --- 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 145cbb6c9db..00000000000 --- 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 ba4b73351aa..00000000000 --- 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 bfb48947753..00000000000 --- 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 6ce87bd7f91..00000000000 --- 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 18f62c7d235..00000000000 --- 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 7cc7526887e..00000000000 --- 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 e1129db9a32..00000000000 --- 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 edc6035a428..00000000000 --- 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 bc8b4a653b9..00000000000 --- 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 1eb168d95a8..00000000000 --- 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 0cc2ccec8b4..00000000000 --- 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 675e7d8ee5a..00000000000 --- 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 6e4fd42893d..00000000000 --- 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 c12ff1e5e29..00000000000 --- 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 f8d498a08b0..00000000000 --- 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 7d9466e5035..00000000000 --- 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 88a758a957e..00000000000 --- 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 b970b7b5d88..00000000000 --- 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 04161144d20..00000000000 --- 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 8c3a208d631..00000000000 --- 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 858a22ff8bc..00000000000 --- 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 e8a28bdfa09..00000000000 --- 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 229db4ecc24..00000000000 --- 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 9c6150abc64..00000000000 --- 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 37abb9c28d7..00000000000 --- 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 31c0e091d0e..00000000000 --- 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 070df3a3bfc..00000000000 --- 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 61ff4217542..00000000000 --- 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 e4f35abd6ce..00000000000 --- 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 c2255168fc9..00000000000 --- 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 a4a717f80b0..00000000000 --- 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 afeec6dfcce..00000000000 --- 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 1255efd6b7d..00000000000 --- 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 42562dce95b..00000000000 --- 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 6a1a06166b5..00000000000 --- 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 27236ee6c0e..00000000000 --- 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 8b89f3012d4..00000000000 --- 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 559bd7b0393..00000000000 --- 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 f4c50159419..00000000000 --- 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 891452a6e5e..00000000000 --- 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 c8e2aab2e2f..00000000000 --- 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 8b5fb3098fb..00000000000 --- 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 77af8d313e5..00000000000 --- 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 f2c43a04828..00000000000 --- 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 9aaf85562e2..00000000000 --- 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 71bb3fc90a7..00000000000 --- 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 d128ba45354..00000000000 --- 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 bb66da1ab1d..00000000000 --- 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 bd14a342e44..00000000000 --- 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 433558089ad..00000000000 --- 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 7d9e15859f2..00000000000 --- 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 217b5b6e593..00000000000 --- 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 5c553a0912e..00000000000 --- 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-diinio.adb b/gcc/ada/s-diinio.adb deleted file mode 100644 index d8f4fcc50f5..00000000000 --- 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-dim.ads b/gcc/ada/s-dim.ads deleted file mode 100644 index f4b10030a1f..00000000000 --- 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 b7f4de96eed..00000000000 --- 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 1b131c411ab..00000000000 --- 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 e4ccf364064..00000000000 --- 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 4a60ee72e8e..00000000000 --- 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 902341c5936..00000000000 --- 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 c87e3848689..00000000000 --- 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-elaall.adb b/gcc/ada/s-elaall.adb deleted file mode 100644 index 8160cf3594c..00000000000 --- 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 f1cf62002da..00000000000 --- 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 d9410f0ca27..00000000000 --- 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 21e6b525f4c..00000000000 --- 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 b30c92541c7..00000000000 --- 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 e88a1572b2d..00000000000 --- 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-exctab.adb b/gcc/ada/s-exctab.adb deleted file mode 100644 index 23a48158092..00000000000 --- 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 3434fd8cab6..00000000000 --- 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 343a723b67d..00000000000 --- 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 ae6936e93dd..00000000000 --- 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 5b4f9673c0c..00000000000 --- 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 79773e825e4..00000000000 --- 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 be16b071284..00000000000 --- 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 dcbbae56f79..00000000000 --- 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 e89c12bac4a..00000000000 --- 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 0c733f869f4..00000000000 --- 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 0e9070514df..00000000000 --- 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 6b416702589..00000000000 --- 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 32aae1aa971..00000000000 --- 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 9c4f292afe5..00000000000 --- 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 47192b9b0a8..00000000000 --- 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 d99215a46e0..00000000000 --- 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 aa1aa11c62f..00000000000 --- 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 be7851bc4fa..00000000000 --- 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 47581b0dbf0..00000000000 --- 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 824327f270e..00000000000 --- 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 5897128a52e..00000000000 --- 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.ads b/gcc/ada/s-fatgen.ads deleted file mode 100644 index 88f641b5f7f..00000000000 --- 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 1f5cd5e0c8a..00000000000 --- 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 03dee602064..00000000000 --- 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 63f3a431e46..00000000000 --- 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 a3b4bcf3120..00000000000 --- 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 ba23e3653c5..00000000000 --- 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.ads b/gcc/ada/s-fileio.ads deleted file mode 100644 index f084d8dc573..00000000000 --- 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 c5ddff76955..00000000000 --- 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-finroo.adb b/gcc/ada/s-finroo.adb deleted file mode 100644 index ec8792338a2..00000000000 --- 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 0e1a16f933e..00000000000 --- 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 29e984afd2b..00000000000 --- 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 970d5563abd..00000000000 --- 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 fca271c46bc..00000000000 --- 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 df8cdf2101c..00000000000 --- 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 f334d96d47f..00000000000 --- 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 b6d6f22d51b..00000000000 --- 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 7e252eefb25..00000000000 --- 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 e040324853e..00000000000 --- 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 3796bc955dc..00000000000 --- 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 b6050cb4de4..00000000000 --- 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 6dfc5277a7b..00000000000 --- 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 4a0aa22fa84..00000000000 --- 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.ads b/gcc/ada/s-htable.ads deleted file mode 100644 index 86fb56352cb..00000000000 --- 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 9f2a56ea2fb..00000000000 --- 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 3726720cd17..00000000000 --- 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 66c76f5d7e6..00000000000 --- 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 987b8b08eeb..00000000000 --- 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 1fc21e76535..00000000000 --- 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 e97e87dd6c3..00000000000 --- 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 bd60dc2d70b..00000000000 --- 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 6faf2f30971..00000000000 --- 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 bbd294306b0..00000000000 --- 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 1bc2135d253..00000000000 --- 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 96d1332494c..00000000000 --- 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 ef5474a4f3c..00000000000 --- 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 0d19e56fcad..00000000000 --- 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 3d141f9f3e8..00000000000 --- 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 3f0da252883..00000000000 --- 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 9c94baa3b6d..00000000000 --- 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 bc938c82981..00000000000 --- 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 86b146b1284..00000000000 --- 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 6c4a78356ba..00000000000 --- 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 8695d95805f..00000000000 --- 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 a70908a28c4..00000000000 --- 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 f9220c7583b..00000000000 --- 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 78d86747a81..00000000000 --- 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 baf4a38c377..00000000000 --- 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 62ec93ad502..00000000000 --- 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 3c4f64f25d9..00000000000 --- 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 c466db3f671..00000000000 --- 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 134f916e368..00000000000 --- 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 44cca399624..00000000000 --- 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 6fbe67aacc6..00000000000 --- 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 022f75ccf3f..00000000000 --- 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 9eb006f13f4..00000000000 --- 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 d8fd5f51c4f..00000000000 --- 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 71897adc8f5..00000000000 --- 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 9504e78a8aa..00000000000 --- 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 353cb0586e8..00000000000 --- 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 04f6e5a5c27..00000000000 --- 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 51692999256..00000000000 --- 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 73be3e9ec15..00000000000 --- 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 216d79bbd15..00000000000 --- 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 fc2403fdfbf..00000000000 --- 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 31fe0d8a04d..00000000000 --- 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 870b68a85cc..00000000000 --- 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 a8c1251c004..00000000000 --- 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 aee0ebeaad0..00000000000 --- 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 7719367c805..00000000000 --- 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 f7fa0bda6f9..00000000000 --- 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 b850630d53c..00000000000 --- 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 ad296c1c5dc..00000000000 --- 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 634d980cb29..00000000000 --- 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 002bf774351..00000000000 --- 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 239d5e0ee73..00000000000 --- 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-osprim-darwin.adb b/gcc/ada/s-osprim-darwin.adb deleted file mode 100644 index 688371d19f4..00000000000 --- 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 6d4f2bf242a..00000000000 --- 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 04344d31b4f..00000000000 --- 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 3bddaa5c8e3..00000000000 --- 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 732a15c5c32..00000000000 --- 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 92dfc993a9b..00000000000 --- 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 b457f5b3201..00000000000 --- 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 ad4ffbee96d..00000000000 --- 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 b081dc27f8f..00000000000 --- 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 265246ce8a3..00000000000 --- 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 645c3a7df6e..00000000000 --- 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 567bdc78551..00000000000 --- 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 e467af0631e..00000000000 --- 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 9db47345386..00000000000 --- 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 45ba8bddd05..00000000000 --- 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 a0fa35d298b..00000000000 --- 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 e0360bbba4f..00000000000 --- 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 78defe038b2..00000000000 --- 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 402c9fa7867..00000000000 --- 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 dc4113efeed..00000000000 --- 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 23edceb12cd..00000000000 --- 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 e812a0057ea..00000000000 --- 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 69b090dc7bb..00000000000 --- 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 ae0af7e635f..00000000000 --- 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 0970d694810..00000000000 --- 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 f58fbf7c61f..00000000000 --- 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 8cae0d7091e..00000000000 --- 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 72cd783c5a6..00000000000 --- 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 4df1841d667..00000000000 --- 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 787ca7ee7e3..00000000000 --- 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 0fc493881bb..00000000000 --- 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 9234b1e5008..00000000000 --- 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 5e2e33f8602..00000000000 --- 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 051d992cbcc..00000000000 --- 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 3a9c2e7f6d2..00000000000 --- 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 03dedb4f426..00000000000 --- 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 b0b9b4b4300..00000000000 --- 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 e75f828f382..00000000000 --- 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 8357a699a7d..00000000000 --- 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 0454df05b48..00000000000 --- 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 ae27d67d53b..00000000000 --- 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 7504ba8b83d..00000000000 --- 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 85f4af96a76..00000000000 --- 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 9057453c1b2..00000000000 --- 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 96cbabf750c..00000000000 --- 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 fde2fa3e666..00000000000 --- 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 e3df996ca44..00000000000 --- 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 d59beebd4bb..00000000000 --- 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 d7edc149e72..00000000000 --- 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 979e8927856..00000000000 --- 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 0a15d878abc..00000000000 --- 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 da77d5746b6..00000000000 --- 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 35daf6d56e7..00000000000 --- 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 996ff25a0fd..00000000000 --- 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 73bc62f36f3..00000000000 --- 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 47bcb234a8b..00000000000 --- 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 ceab502f7ca..00000000000 --- 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 aa8585018f5..00000000000 --- 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 d0eada3337d..00000000000 --- 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 5667e6fee59..00000000000 --- 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 0cbbf658d11..00000000000 --- 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 085298b10e6..00000000000 --- 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 b97c63d0689..00000000000 --- 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 668f8066cd8..00000000000 --- 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 98bbd8586c7..00000000000 --- 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 a1e8e0c3c9d..00000000000 --- 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 9303a508487..00000000000 --- 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 456c7fa967c..00000000000 --- 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 ec4a21ac77d..00000000000 --- 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 8b8084346be..00000000000 --- 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 b12166ebfc9..00000000000 --- 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 f2a98891c0b..00000000000 --- 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 85c942a6414..00000000000 --- 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 8ba083db4df..00000000000 --- 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 993fc95dce7..00000000000 --- 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 1f30ee358ce..00000000000 --- 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 dd580c06fa5..00000000000 --- 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 8dcae701a0c..00000000000 --- 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 bc8285a53d5..00000000000 --- 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 73872fd1dd2..00000000000 --- 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 509cb006ef7..00000000000 --- 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 f82678f6efd..00000000000 --- 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 f7fe185573a..00000000000 --- 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 89b3f3e747e..00000000000 --- 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 2247312e77a..00000000000 --- 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 2340d48fb23..00000000000 --- 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 c2b45f054df..00000000000 --- 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 6ab8dfe5ccc..00000000000 --- 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 d63e35df574..00000000000 --- 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 f924965b3eb..00000000000 --- 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 780a15793d5..00000000000 --- 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 ba1008e68b7..00000000000 --- 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 a9cad236810..00000000000 --- 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 649e5502313..00000000000 --- 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 7cc04e69dac..00000000000 --- 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 699165b49a7..00000000000 --- 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 5617a983ae7..00000000000 --- 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 99bdd512267..00000000000 --- 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 5adf132af9e..00000000000 --- 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 fab35eecc5d..00000000000 --- 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 471d1fc1c2c..00000000000 --- 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 380278c2eef..00000000000 --- 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 5d0294178e7..00000000000 --- 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 5ee9a886678..00000000000 --- 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 be264e1318f..00000000000 --- 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 8dce9fa7141..00000000000 --- 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 fd34211bf37..00000000000 --- 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 5e6578bb50c..00000000000 --- 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 b477b2e5589..00000000000 --- 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 aff3c500c33..00000000000 --- 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 1aeb45003fe..00000000000 --- 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 503d990e0e9..00000000000 --- 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 35199ce47bd..00000000000 --- 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 2abbbf2efc3..00000000000 --- 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 e909f71b6a9..00000000000 --- 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 bc4886878ed..00000000000 --- 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 cd29c81294d..00000000000 --- 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 ac309a230f8..00000000000 --- 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 b13754df5c7..00000000000 --- 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 b8b19f4a4f1..00000000000 --- 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 109f914b9b3..00000000000 --- 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 c59678b4cd4..00000000000 --- 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-vxworks.adb b/gcc/ada/s-parame-vxworks.adb deleted file mode 100644 index c27b092a498..00000000000 --- 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.adb b/gcc/ada/s-parame.adb deleted file mode 100644 index 9a40c6f6be3..00000000000 --- 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-parint.adb b/gcc/ada/s-parint.adb deleted file mode 100644 index 53cc49cdb14..00000000000 --- 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 a6257cc72b3..00000000000 --- 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 e4dcdb091c7..00000000000 --- 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 99100f819fc..00000000000 --- 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 ebada306114..00000000000 --- 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 1e7c8accd2d..00000000000 --- 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 da3a0c5594c..00000000000 --- 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 0e83dd61937..00000000000 --- 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 5a84b50f4c5..00000000000 --- 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-rannum.adb b/gcc/ada/s-rannum.adb deleted file mode 100644 index c024249ad09..00000000000 --- 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 a98631158e8..00000000000 --- 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 3f97ca3fd5f..00000000000 --- 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 8e4071fa5b2..00000000000 --- 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-regpat.ads b/gcc/ada/s-regpat.ads deleted file mode 100644 index 5c8bf5e1c3c..00000000000 --- 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-restri.adb b/gcc/ada/s-restri.adb deleted file mode 100644 index bd87b1705ec..00000000000 --- 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 66c6584a2ac..00000000000 --- 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-rpc.adb b/gcc/ada/s-rpc.adb deleted file mode 100644 index 1ffb9b9847c..00000000000 --- 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 2c23e5cff91..00000000000 --- 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 632e30e4b01..00000000000 --- 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 9ebbd50bbb6..00000000000 --- 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 1cb1b1b9782..00000000000 --- 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 c5a0eadf29f..00000000000 --- 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 e47c75fd4bb..00000000000 --- 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 5cbe3d92bf2..00000000000 --- 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 38787ccf2bc..00000000000 --- 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 51e49e8b543..00000000000 --- 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 d1c10a0c67e..00000000000 --- 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 35dc9628b98..00000000000 --- 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 9c4e00557ea..00000000000 --- 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 89dd9cfb8f9..00000000000 --- 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 fc3a7402c44..00000000000 --- 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 79cd3ddfcf8..00000000000 --- 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 6be4d5b338b..00000000000 --- 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 2521279c4be..00000000000 --- 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 e6baee0f049..00000000000 --- 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 319ed978f02..00000000000 --- 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 927e0ab154c..00000000000 --- 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 374f676df6d..00000000000 --- 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 1b95c6a3959..00000000000 --- 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 d00d23b7942..00000000000 --- 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 6ccc386c7f4..00000000000 --- 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 c0449e8fbc8..00000000000 --- 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 237c0f9e051..00000000000 --- 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-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb deleted file mode 100644 index 53f6c457c02..00000000000 --- 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 05b13dcbe8c..00000000000 --- 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 014eddc417a..00000000000 --- 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 1cb5f92a23c..00000000000 --- 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 bf773cb03d4..00000000000 --- 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 3ac5beb176c..00000000000 --- 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 d6153acd409..00000000000 --- 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.ads b/gcc/ada/s-stposu.ads deleted file mode 100644 index f473dc279b9..00000000000 --- 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 1c5d3cf62d1..00000000000 --- 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 796665ff795..00000000000 --- 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 a831cdb4ac3..00000000000 --- 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 4388d801e68..00000000000 --- 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 7458f5da015..00000000000 --- 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 9ab5b6e423b..00000000000 --- 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 d0dd4c8a225..00000000000 --- 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 88439ccf2bc..00000000000 --- 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 ee054987655..00000000000 --- 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 a822ea48c44..00000000000 --- 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 8e6d7b44b6f..00000000000 --- 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-tasloc.adb b/gcc/ada/s-tasloc.adb deleted file mode 100644 index ce95b6d1bd2..00000000000 --- 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 5e370bba36e..00000000000 --- 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 dcd6ad0b64f..00000000000 --- 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 1a00d97f1e6..00000000000 --- 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 e4671135ade..00000000000 --- 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 283bd5cd072..00000000000 --- 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 48abe8a1193..00000000000 --- 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 4d834261d8b..00000000000 --- 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.ads b/gcc/ada/s-trasym.ads deleted file mode 100644 index ba9c89ea6c6..00000000000 --- 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-unstyp.ads b/gcc/ada/s-unstyp.ads deleted file mode 100644 index f9ad3853a0a..00000000000 --- 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 cb41b2fede6..00000000000 --- 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 1d01fa5d4a6..00000000000 --- 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 59c79ef15a9..00000000000 --- 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 3b699240201..00000000000 --- 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 799145fa893..00000000000 --- 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 193f9bdfdc0..00000000000 --- 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 ecd76821cae..00000000000 --- 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 71c98129cdd..00000000000 --- 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 0de1a9520ee..00000000000 --- 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 fa5d205d420..00000000000 --- 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 11812971b92..00000000000 --- 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 08b229bb477..00000000000 --- 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 0fef8a4b22e..00000000000 --- 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 c4d089bfed6..00000000000 --- 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 bf0e15d1234..00000000000 --- 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 c1aceb35da2..00000000000 --- 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 44dbff7c3df..00000000000 --- 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 216ce21351b..00000000000 --- 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 7284e6007f6..00000000000 --- 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 8d3603f8eb4..00000000000 --- 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 009d0bc88c1..00000000000 --- 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 cdea7409e23..00000000000 --- 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 6d6b827a79c..00000000000 --- 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 a2db3432b68..00000000000 --- 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 87e85464301..00000000000 --- 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 4bf9309bb5a..00000000000 --- 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 dea318abb2b..00000000000 --- 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 9553dd1d9bd..00000000000 --- 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 4c529b2924b..00000000000 --- 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 7c2f89f1ce6..00000000000 --- 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 4513d9dac6c..00000000000 --- 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 ffbb991b2da..00000000000 --- 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 82a620aa182..00000000000 --- 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 55acd048adf..00000000000 --- 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 7b081acdf03..00000000000 --- 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 6b4941c8d3f..00000000000 --- 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 58b4bf1d33a..00000000000 --- 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 e50f4c2f61e..00000000000 --- 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 7445c59e99b..00000000000 --- 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 895221e88dc..00000000000 --- 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 56914e64cec..00000000000 --- 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 a6e46633af2..00000000000 --- 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 9aa465b2544..00000000000 --- 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 c8fd2995777..00000000000 --- 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 cfea76416dc..00000000000 --- 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 08731427e1c..00000000000 --- 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 3cdb532dc37..00000000000 --- 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 4d0aa3a5e92..00000000000 --- 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 bbc3f03e312..00000000000 --- 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 8f30f80fbb3..00000000000 --- 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 7f1fd5dde76..00000000000 --- 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 5d9df7bf7bc..00000000000 --- 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 244db86655e..00000000000 --- 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 6fafd526a43..00000000000 --- 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 803a6483ca4..00000000000 --- 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 d7f40e35ee3..00000000000 --- 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 04f171dda45..00000000000 --- 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 5006ec516c9..00000000000 --- 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 c80cc4b11f6..00000000000 --- 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 001680ef5be..00000000000 --- 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 ecdd93f5108..00000000000 --- 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/system-aix.ads b/gcc/ada/system-aix.ads deleted file mode 100644 index 95815b41f74..00000000000 --- 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 9b96bf91914..00000000000 --- 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 7809e14c90b..00000000000 --- 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 7fce58784a8..00000000000 --- 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-hpux-ia64.ads b/gcc/ada/system-hpux-ia64.ads deleted file mode 100644 index b6581e89716..00000000000 --- 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 852dcac674e..00000000000 --- 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 e78153436c2..00000000000 --- 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-hppa.ads b/gcc/ada/system-linux-hppa.ads deleted file mode 100644 index 83aba27ddee..00000000000 --- 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 8fe46977049..00000000000 --- 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-sh4.ads b/gcc/ada/system-linux-sh4.ads deleted file mode 100644 index dcd28a01f93..00000000000 --- 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 503adbe6f3b..00000000000 --- 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-mingw.ads b/gcc/ada/system-mingw.ads deleted file mode 100644 index 82b5d0cff90..00000000000 --- 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-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads deleted file mode 100644 index 79614aaa520..00000000000 --- 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 d598fe9fa43..00000000000 --- 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 2b1fb8e9e42..00000000000 --- 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 37b7d1db8f9..00000000000 --- 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 22f42f3c6da..00000000000 --- 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; -- 2.30.2